diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 005fbe10a9..dcf9061370 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 @@ -575,6 +576,7 @@ test-suite simplex-chat-test ChatTests.ChatList ChatTests.Direct ChatTests.Files + ChatTests.Forward ChatTests.Groups ChatTests.Local ChatTests.Profiles diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index d075c6cf70..41f8828b26 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -82,7 +82,7 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.Types.Util -import Simplex.Chat.Util (encryptFile, shuffle) +import Simplex.Chat.Util (encryptFile, liftIOEither, shuffle) import Simplex.FileTransfer.Client.Main (maxFileSize, maxFileSizeHard) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription) @@ -705,105 +705,28 @@ processChatCommand' vr = \case [] -> pure Nothing 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 -> case cType of - CTDirect -> withContactLock "sendMessage" chatId $ 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 -> withGroupLock "sendMessage" chatId $ do - g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId - assertUserGroupRole gInfo GRAuthor - send g - where - send g@(Group gInfo@GroupInfo {groupId, membership} ms) = - case prohibitedGroupContent gInfo membership mc file_ of - Just f -> notAllowedError f - Nothing -> 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 + forwardedFromChatItem <- getForwardedFromItem user ci + pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses, forwardedFromChatItem} + where + getForwardedFromItem :: User -> ChatItem c d -> CM (Maybe AChatItem) + getForwardedFromItem user ChatItem {meta = CIMeta {itemForwarded}} = case itemForwarded of + Just (CIFFContact _ _ (Just ctId) (Just fwdItemId)) -> + Just <$> withStore (\db -> getAChatItem db vr user (ChatRef CTDirect ctId) fwdItemId) + Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) -> + Just <$> withStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) + _ -> pure Nothing + APISendMessage (ChatRef cType chatId) live itemTTL cm -> withUser $ \user -> case cType of + CTDirect -> + withContactLock "sendMessage" chatId $ + sendContactContentMessage user chatId live itemTTL cm Nothing + CTGroup -> + withGroupLock "sendMessage" chatId $ + 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 -> case cType of CTDirect -> withContactLock "updateChatItem" chatId $ do ct@Contact {contactId} <- withStore $ \db -> getContact db vr user chatId @@ -948,6 +871,91 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") + APIForwardChatItem (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemId -> withUser $ \user -> case toCType of + CTDirect -> do + (cm, ciff) <- prepareForward user + withContactLock "forwardChatItem, to contact" toChatId $ + sendContactContentMessage user toChatId False Nothing cm ciff + CTGroup -> do + (cm, ciff) <- prepareForward user + withGroupLock "forwardChatItem, to group" toChatId $ + sendGroupContentMessage user toChatId False Nothing cm ciff + CTLocal -> do + (cm, ciff) <- prepareForward user + createNoteFolderContentItem user toChatId cm ciff + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + prepareForward :: User -> CM (ComposedMessage, Maybe CIForwardedFrom) + prepareForward user = case fromCType of + CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do + (ct, CChatItem _ ci) <- withStore $ \db -> do + ct <- getContact db vr user fromChatId + cci <- getDirectChatItem db user fromChatId itemId + pure (ct, cci) + (mc, mDir) <- forwardMC ci + file <- forwardCryptoFile ci `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing) + let ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId)) + pure (ComposedMessage file Nothing mc, ciff) + where + forwardName :: Contact -> ContactName + forwardName Contact {profile = LocalProfile {displayName, localAlias}} + | localAlias /= "" = localAlias + | otherwise = displayName + CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do + (gInfo, CChatItem _ ci) <- withStore $ \db -> do + gInfo <- getGroupInfo db vr user fromChatId + cci <- getGroupChatItem db user fromChatId itemId + pure (gInfo, cci) + (mc, mDir) <- forwardMC ci + file <- forwardCryptoFile ci `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing) + let ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId)) + pure (ComposedMessage file Nothing mc, ciff) + where + forwardName :: GroupInfo -> ContactName + forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName + CTLocal -> do + (CChatItem _ ci) <- withStore $ \db -> getLocalChatItem db user fromChatId itemId + (mc, _) <- forwardMC ci + file <- forwardCryptoFile ci `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing) + let ciff = forwardCIFF ci Nothing + pure (ComposedMessage file Nothing mc, ciff) + CTContactRequest -> throwChatError $ CECommandError "not supported" + CTContactConnection -> throwChatError $ CECommandError "not supported" + where + forwardMC :: ChatItem c d -> CM (MsgContent, MsgDirection) + forwardMC ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidForward + forwardMC ChatItem {content = CISndMsgContent fmc} = pure (fmc, MDSnd) + forwardMC ChatItem {content = CIRcvMsgContent fmc} = pure (fmc, MDRcv) + forwardMC _ = throwChatError CEInvalidForward + forwardCIFF :: ChatItem c d -> Maybe CIForwardedFrom -> Maybe CIForwardedFrom + forwardCIFF ChatItem {meta = CIMeta {itemForwarded = Just ciff}} _ = Just ciff + forwardCIFF _ ciff = ciff + forwardCryptoFile :: ChatItem c d -> CM (Maybe CryptoFile) + forwardCryptoFile ChatItem {file = Just CIFile {fileName, fileStatus, fileSource = Just fromCF@CryptoFile {filePath}}} + | ciFileLoaded fileStatus = + chatReadVar filesFolder >>= \case + Nothing -> + ifM (doesFileExist filePath) (pure $ Just fromCF) (pure Nothing) + Just filesFolder -> do + let fsFromPath = filesFolder filePath + ifM + (doesFileExist fsFromPath) + ( do + fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName + liftIO $ B.writeFile fsNewPath "" -- create empty file + encrypt <- chatReadVar encryptLocalFiles + cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing + let toCF = CryptoFile fsNewPath cfArgs + -- to keep forwarded file in case original is deleted + liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $ do + lb <- CF.readFile (fromCF {filePath = fsFromPath} :: CryptoFile) + CF.writeFile toCF lb + pure $ Just (toCF {filePath = takeFileName fsNewPath} :: CryptoFile) + ) + (pure Nothing) + | otherwise = pure Nothing + forwardCryptoFile _ = pure Nothing 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 @@ -1554,6 +1562,21 @@ processChatCommand' vr = \case RejectContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIRejectContact connReqId + ForwardMessage toChatName fromContactName forwardedMsg -> withUser $ \user -> do + contactId <- withStore $ \db -> getContactIdByName db user fromContactName + forwardedItemId <- withStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTDirect contactId) forwardedItemId + ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user fromGroupName + forwardedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTGroup groupId) forwardedItemId + ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do + folderId <- withStore (`getUserNoteFolderId` user) + forwardedItemId <- withStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTLocal folderId) forwardedItemId SendMessage (ChatName cType name) msg -> withUser $ \user -> do let mc = MCText msg case cType of @@ -1638,7 +1661,7 @@ 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 @@ -2060,7 +2083,7 @@ processChatCommand' vr = \case p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} SetGroupFeatureRole (AGFR f) gName enabled role -> updateGroupProfileByName gName $ \p -> - p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p} + p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p} SetUserTimedMessages onOff -> withUser $ \user@User {profile} -> do let allowed = if onOff then FAYes else FANo pref = TimedMessagesPreference allowed Nothing @@ -2587,6 +2610,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@GroupInfo {membership} ms) = + case prohibitedGroupContent gInfo membership mc file_ of + Just f -> notAllowedError f + Nothing -> 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 = @@ -2601,10 +2722,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 @@ -2612,6 +2734,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 @@ -4049,7 +4172,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 @@ -4669,18 +4792,19 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = updateRcvChatItem = do cci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId case cci of - CChatItem SMDRcv ci@ChatItem {meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - ci' <- withStore' $ \db -> do - when changed $ - addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) - reactions <- getDirectCIReactions db ct sharedMsgId - updateDirectChatItem' db user contactId ci {reactions} content live $ Just msgId - toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') - startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' - else toView $ CRChatItemNotChanged user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) + CChatItem SMDRcv ci@ChatItem {meta = CIMeta {itemForwarded, itemLive}, content = CIRcvMsgContent oldMC} + | isNothing itemForwarded -> do + let changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + ci' <- withStore' $ \db -> do + when changed $ + addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) + reactions <- getDirectCIReactions db ct sharedMsgId + updateDirectChatItem' db user contactId ci {reactions} content live $ Just msgId + toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') + startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' + else toView $ CRChatItemNotChanged user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) _ -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM () @@ -6441,17 +6565,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 = @@ -6460,18 +6584,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 itemForwarded Nothing 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 @@ -6732,17 +6856,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 = @@ -6869,6 +6993,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)))), @@ -7010,6 +7135,10 @@ chatCommandP = "/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP), ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)), ("/connect" <|> "/c") *> (AddContact <$> incognitoP), + ForwardMessage <$> chatNameP <* " <- @" <*> displayName <* A.space <*> msgTextP, + ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayName <* A.space <* A.char '@' <*> (Just <$> displayName) <* A.space <*> msgTextP, + ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayName <*> pure Nothing <* A.space <*> msgTextP, + ForwardLocalMessage <$> chatNameP <* " <- * " <*> msgTextP, SendMessage <$> chatNameP <* A.space <*> msgTextP, "/* " *> (SendMessage (ChatName CTLocal "") <$> msgTextP), "@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 85d93a7d88..5295541697 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -292,6 +292,7 @@ data ChatCommand | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} + | APIForwardChatItem {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemId :: ChatItemId} | APIUserRead UserId | UserRead | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) @@ -408,6 +409,9 @@ data ChatCommand | AddressAutoAccept (Maybe AutoAccept) | AcceptContact IncognitoEnabled ContactName | RejectContact ContactName + | ForwardMessage {toChatName :: ChatName, fromContactName :: ContactName, forwardedMsg :: Text} + | ForwardGroupMessage {toChatName :: ChatName, fromGroupName :: GroupName, fromMemberName_ :: Maybe ContactName, forwardedMsg :: Text} + | ForwardLocalMessage {toChatName :: ChatName, forwardedMsg :: Text} | SendMessage ChatName Text | SendMemberContactMessage GroupName ContactName Text | SendLiveMessage ChatName Text @@ -1114,6 +1118,7 @@ data ChatErrorType | CEFallbackToSMPProhibited {fileId :: FileTransferId} | CEInlineFileProhibited {fileId :: FileTransferId} | CEInvalidQuote + | CEInvalidForward | CEInvalidChatItemUpdate | CEInvalidChatItemDelete | CEHasCurrentCall diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index b29543cf74..2aa781d45e 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -339,6 +339,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta itemText :: Text, itemStatus :: CIStatus d, itemSharedMsgId :: Maybe SharedMsgId, + itemForwarded :: Maybe CIForwardedFrom, itemDeleted :: Maybe (CIDeleted c), itemEdited :: Bool, itemTimed :: Maybe CITimed, @@ -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 CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d +mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemForwarded itemDeleted 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 + SCTLocal -> isNothing itemDeleted && isNothing itemForwarded + _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted && isNothing itemForwarded _ -> False - in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, forwardedByMember, createdAt, updatedAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, editable, forwardedByMember, createdAt, updatedAt} dummyMeta :: ChatItemId -> UTCTime -> Text -> CIMeta c 'MDSnd dummyMeta itemId ts itemText = @@ -368,6 +369,7 @@ dummyMeta itemId ts itemText = itemText, itemStatus = CISSndNew, itemSharedMsgId = Nothing, + itemForwarded = Nothing, itemDeleted = Nothing, itemEdited = False, itemTimed = Nothing, @@ -548,6 +550,21 @@ ciFileEnded = \case CIFSRcvError -> True CIFSInvalid {} -> True +ciFileLoaded :: CIFileStatus d -> Bool +ciFileLoaded = \case + CIFSSndStored -> True + CIFSSndTransfer {} -> True + CIFSSndComplete -> True + CIFSSndCancelled -> True + CIFSSndError -> True + CIFSRcvInvitation -> False + CIFSRcvAccepted -> False + CIFSRcvTransfer {} -> False + CIFSRcvCancelled -> False + CIFSRcvComplete -> True + CIFSRcvError -> False + CIFSInvalid {} -> False + data ACIFileStatus = forall d. MsgDirectionI d => AFS (SMsgDirection d) (CIFileStatus d) deriving instance Show ACIFileStatus @@ -981,11 +998,43 @@ itemDeletedTs = \case CIBlockedByAdmin ts -> ts CIModerated ts _ -> ts +data CIForwardedFrom + = CIFFUnknown + | CIFFContact {chatName :: Text, msgDir :: MsgDirection, contactId :: Maybe ContactId, chatItemId :: Maybe ChatItemId} + | CIFFGroup {chatName :: Text, msgDir :: MsgDirection, groupId :: Maybe GroupId, chatItemId :: Maybe ChatItemId} + deriving (Show) + +cmForwardedFrom :: AChatMsgEvent -> Maybe CIForwardedFrom +cmForwardedFrom = \case + ACME _ (XMsgNew (MCForward _)) -> Just CIFFUnknown + _ -> Nothing + +data CIForwardedFromTag + = CIFFUnknown_ + | CIFFContact_ + | CIFFGroup_ + +instance FromField CIForwardedFromTag where fromField = fromTextField_ textDecode + +instance ToField CIForwardedFromTag where toField = toField . textEncode + +instance TextEncoding CIForwardedFromTag where + textDecode = \case + "unknown" -> Just CIFFUnknown_ + "contact" -> Just CIFFContact_ + "group" -> Just CIFFGroup_ + _ -> Nothing + textEncode = \case + CIFFUnknown_ -> "unknown" + CIFFContact_ -> "contact" + CIFFGroup_ -> "group" + data ChatItemInfo = ChatItemInfo { itemVersions :: [ChatItemVersion], - memberDeliveryStatuses :: Maybe [MemberDeliveryStatus] + memberDeliveryStatuses :: Maybe [MemberDeliveryStatus], + forwardedFromChatItem :: Maybe AChatItem } - deriving (Eq, Show) + deriving (Show) data ChatItemVersion = ChatItemVersion { chatItemVersionId :: Int64, @@ -1043,6 +1092,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) @@ -1066,8 +1117,6 @@ $(JQ.deriveJSON defaultJSON ''MemberDeliveryStatus) $(JQ.deriveJSON defaultJSON ''ChatItemVersion) -$(JQ.deriveJSON defaultJSON ''ChatItemInfo) - instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIMeta c d) where parseJSON = $(JQ.mkParseJSON defaultJSON ''CIMeta) @@ -1157,6 +1206,8 @@ instance ChatTypeI c => ToJSON (CChatItem c) where toJSON (CChatItem _ ci) = J.toJSON ci toEncoding (CChatItem _ ci) = J.toEncoding ci +$(JQ.deriveJSON defaultJSON ''ChatItemInfo) + $(JQ.deriveJSON defaultJSON ''ChatStats) instance ChatTypeI c => ToJSON (Chat c) where diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 9266a0c1ca..13aa7ace10 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -43,6 +43,8 @@ $(JQ.deriveJSON (enumJSON $ dropPrefix "MD") ''MsgDirection) instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgDirection . msgDirectionIntP +instance FromField MsgDirection where fromField = fromIntField_ msgDirectionIntP + instance ToField MsgDirection where toField = toField . msgDirectionInt data SMsgDirection (d :: MsgDirection) where 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..850c8be2d9 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20240402_item_forwarded.hs @@ -0,0 +1,36 @@ +{-# 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 fwd_from_tag TEXT; +ALTER TABLE chat_items ADD COLUMN fwd_from_chat_name TEXT; +ALTER TABLE chat_items ADD COLUMN fwd_from_msg_dir INTEGER; +ALTER TABLE chat_items ADD COLUMN fwd_from_contact_id INTEGER REFERENCES contacts ON DELETE SET NULL; +ALTER TABLE chat_items ADD COLUMN fwd_from_group_id INTEGER REFERENCES groups ON DELETE SET NULL; +ALTER TABLE chat_items ADD COLUMN fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL; + +CREATE INDEX idx_chat_items_fwd_from_contact_id ON chat_items(fwd_from_contact_id); +CREATE INDEX idx_chat_items_fwd_from_group_id ON chat_items(fwd_from_group_id); +CREATE INDEX idx_chat_items_fwd_from_chat_item_id ON chat_items(fwd_from_chat_item_id); +|] + +down_m20240402_item_forwarded :: Query +down_m20240402_item_forwarded = + [sql| +DROP INDEX idx_chat_items_fwd_from_contact_id; +DROP INDEX idx_chat_items_fwd_from_group_id; +DROP INDEX idx_chat_items_fwd_from_chat_item_id; + +ALTER TABLE chat_items DROP COLUMN fwd_from_tag; +ALTER TABLE chat_items DROP COLUMN fwd_from_chat_name; +ALTER TABLE chat_items DROP COLUMN fwd_from_msg_dir; +ALTER TABLE chat_items DROP COLUMN fwd_from_contact_id; +ALTER TABLE chat_items DROP COLUMN fwd_from_group_id; +ALTER TABLE chat_items DROP COLUMN fwd_from_chat_item_id; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 11cbd8ae89..f2d8e59ca7 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -382,7 +382,13 @@ 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, + fwd_from_tag TEXT, + fwd_from_chat_name TEXT, + fwd_from_msg_dir INTEGER, + fwd_from_contact_id INTEGER REFERENCES contacts ON DELETE SET NULL, + fwd_from_group_id INTEGER REFERENCES groups ON DELETE SET NULL, + fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL ); CREATE TABLE chat_item_messages( chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE, @@ -860,3 +866,10 @@ 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_fwd_from_contact_id ON chat_items( + fwd_from_contact_id +); +CREATE INDEX idx_chat_items_fwd_from_group_id ON chat_items(fwd_from_group_id); +CREATE INDEX idx_chat_items_fwd_from_chat_item_id ON chat_items( + fwd_from_chat_item_id +); diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index e262de0e74..6cdc52a499 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -588,6 +588,7 @@ parseMsgContainer :: J.Object -> JT.Parser MsgContainer parseMsgContainer v = MCQuote <$> v .: "quote" <*> mc <|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc) + <|> (MCForward <$> ((v .: "forward" :: JT.Parser J.Object) *> mc)) <|> MCSimple <$> mc where mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index fe89d7f506..11068ff5cb 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 + fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_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,16 @@ 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 CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64) + forwardedFromRow = case itemForwarded of + Nothing -> + (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) + Just CIFFUnknown -> + (Just CIFFUnknown_, Nothing, Nothing, Nothing, Nothing, Nothing) + Just CIFFContact {chatName, msgDir, contactId, chatItemId} -> + (Just CIFFContact_, Just chatName, Just msgDir, contactId, Nothing, chatItemId) + Just CIFFGroup {chatName, msgDir, groupId, chatItemId} -> + (Just CIFFContact_, Just chatName, Just msgDir, Nothing, groupId, chatItemId) ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime) ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt) @@ -794,7 +807,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 +839,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 itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -1391,7 +1405,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 CIForwardedFromTag, Maybe Text, Maybe MsgDirection, 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 +1427,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 +1459,19 @@ 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 itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} +toCIForwardedFrom :: ChatItemForwardedFromRow -> Maybe CIForwardedFrom +toCIForwardedFrom (fwdFromTag, fwdFromChatName, fwdFromMsgDir, fwdFromContactId, fwdFromGroupId, fwdFromChatItemId) = + case (fwdFromTag, fwdFromChatName, fwdFromMsgDir, fwdFromContactId, fwdFromGroupId, fwdFromChatItemId) of + (Just CIFFUnknown_, Nothing, Nothing, Nothing, Nothing, Nothing) -> Just CIFFUnknown + (Just CIFFContact_, Just chatName, Just msgDir, contactId, Nothing, chatId) -> Just $ CIFFContact chatName msgDir contactId chatId + (Just CIFFGroup_, Just chatName, Just msgDir, Nothing, groupId, chatId) -> Just $ CIFFGroup chatName msgDir groupId chatId + _ -> Nothing + type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) @@ -1454,7 +1484,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 +1521,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 itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -1726,7 +1757,10 @@ 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.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_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 +2000,10 @@ 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.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_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 +2104,10 @@ 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.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_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 diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 7b96abc1ce..5c36994190 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -86,7 +86,10 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do Right SendLiveMessage {} -> True Right SendFile {} -> True Right SendMessageQuote {} -> True + Right ForwardMessage {} -> True + Right ForwardLocalMessage {} -> True Right SendGroupMessageQuote {} -> True + Right ForwardGroupMessage {} -> True Right SendMessageBroadcast {} -> True _ -> False startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO () diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 55e0078d0d..c136300bc5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -536,60 +536,68 @@ viewChats ts tz = concatMap chatPreview . reverse _ -> [] viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] -viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz = +viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember}, content, quotedItem, file} doShow ts tz = withGroupMsgForwarded . withItemDeleted <$> viewCI where viewCI = case chat of DirectChat c -> case chatDir of CIDirectSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to context mc CISndGroupEvent {} -> showSndItemProhibited to _ -> showSndItem to where to = ttyToContact' c CIDirectRcv -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta CIRcvGroupEvent {} -> showRcvItemProhibited from _ -> showRcvItem from where from = ttyFromContact c where - quote = maybe [] (directQuote chatDir) quotedItem + context = + maybe + (maybe [] forwardedFrom itemForwarded) + (directQuote chatDir) + quotedItem GroupChat g -> case chatDir of CIGroupSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to context mc CISndGroupInvitation {} -> showSndItemProhibited to _ -> showSndItem to where to = ttyToGroup g CIGroupRcv m -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta CIRcvGroupInvitation {} -> showRcvItemProhibited from - CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False - CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False + CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False + CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False _ -> showRcvItem from where from = ttyFromGroup g m where - quote = maybe [] (groupQuote g) quotedItem + context = + maybe + (maybe [] forwardedFrom itemForwarded) + (groupQuote g) + quotedItem LocalChat _ -> case chatDir of CILocalSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withLocalFile to $ sndMsg to quote mc + CISndMsgContent mc -> hideLive meta $ withLocalFile to $ sndMsg to context mc CISndGroupEvent {} -> showSndItemProhibited to _ -> showSndItem to where to = "* " CILocalRcv -> case content of - CIRcvMsgContent mc -> withLocalFile from $ rcvMsg from quote mc + CIRcvMsgContent mc -> withLocalFile from $ rcvMsg from context mc CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta CIRcvGroupEvent {} -> showRcvItemProhibited from _ -> showRcvItem from where from = "* " where - quote = [] + context = maybe [] forwardedFrom itemForwarded ContactRequest {} -> [] ContactConnection {} -> [] withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of @@ -604,10 +612,10 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, withFile view dir l = maybe l (\f -> l <> view dir f ts tz meta) file sndMsg = msg viewSentMessage rcvMsg = msg viewReceivedMessage - msg view dir quote mc = case (msgContentText mc, file, quote) of + msg view dir context mc = case (msgContentText mc, file, context) of ("", Just _, []) -> [] - ("", Just CIFile {fileName}, _) -> view dir quote (MCText $ T.pack fileName) ts tz meta - _ -> view dir quote mc ts tz meta + ("", Just CIFile {fileName}, _) -> view dir context (MCText $ T.pack fileName) ts tz meta + _ -> view dir context mc ts tz meta showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content] meta showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content] False showSndItemProhibited to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> " " <> prohibited] meta @@ -617,11 +625,12 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, prohibited = styled (colored Red) ("[unexpected chat item created, please report to developers]" :: String) viewChatItemInfo :: AChatItem -> ChatItemInfo -> TimeZone -> [StyledString] -viewChatItemInfo (AChatItem _ msgDir _ ChatItem {meta = CIMeta {itemTs, itemTimed, createdAt}}) ChatItemInfo {itemVersions} tz = +viewChatItemInfo (AChatItem _ msgDir _ ChatItem {meta = CIMeta {itemTs, itemTimed, createdAt}}) ChatItemInfo {itemVersions, forwardedFromChatItem} tz = ["sent at: " <> ts itemTs] <> receivedAt <> toBeDeletedAt <> versions + <> forwardedFrom' where ts = styleTime . localTs tz receivedAt = case msgDir of @@ -634,7 +643,21 @@ viewChatItemInfo (AChatItem _ msgDir _ ChatItem {meta = CIMeta {itemTs, itemTime if null itemVersions then [] else ["message history:"] <> concatMap version itemVersions - version ChatItemVersion {msgContent, itemVersionTs} = prependFirst (ts itemVersionTs <> styleTime ": ") $ ttyMsgContent msgContent + where + version ChatItemVersion {msgContent, itemVersionTs} = prependFirst (ts itemVersionTs <> styleTime ": ") $ ttyMsgContent msgContent + forwardedFrom' = + case forwardedFromChatItem of + Just fwdACI@(AChatItem _ fwdMsgDir fwdChatInfo _) -> + [plain $ "forwarded from: " <> maybe "" (<> ", ") fwdDir_ <> fwdItemId] + where + fwdDir_ = case (fwdMsgDir, fwdChatInfo) of + (SMDSnd, DirectChat ct) -> Just $ "you @" <> viewContactName ct + (SMDRcv, DirectChat ct) -> Just $ "@" <> viewContactName ct + (SMDSnd, GroupChat gInfo) -> Just $ "you #" <> viewGroupName gInfo + (SMDRcv, GroupChat gInfo) -> Just $ "#" <> viewGroupName gInfo + _ -> Nothing + fwdItemId = "chat item id: " <> (T.pack . show $ aChatItemId fwdACI) + _ -> [] localTs :: TimeZone -> UTCTime -> String localTs tz ts = do @@ -666,37 +689,45 @@ viewDeliveryReceipt = \case MRBadMsgHash -> ttyError' "⩗!" viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] -viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive}, content, quotedItem} liveItems ts tz = case chat of +viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, itemEdited, itemLive}, content, quotedItem} liveItems ts tz = case chat of DirectChat c -> case chatDir of CIDirectRcv -> case content of CIRcvMsgContent mc | itemLive == Just True && not liveItems -> [] - | otherwise -> viewReceivedUpdatedMessage from quote mc ts tz meta + | otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta _ -> [] where from = if itemEdited then ttyFromContactEdited c else ttyFromContact c CIDirectSnd -> case content of - CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts tz meta + CISndMsgContent mc -> hideLive meta $ viewSentMessage to context mc ts tz meta _ -> [] where to = if itemEdited then ttyToContactEdited' c else ttyToContact' c where - quote = maybe [] (directQuote chatDir) quotedItem + context = + maybe + (maybe [] forwardedFrom itemForwarded) + (directQuote chatDir) + quotedItem GroupChat g -> case chatDir of CIGroupRcv m -> case content of CIRcvMsgContent mc | itemLive == Just True && not liveItems -> [] - | otherwise -> viewReceivedUpdatedMessage from quote mc ts tz meta + | otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta _ -> [] where from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m CIGroupSnd -> case content of - CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts tz meta + CISndMsgContent mc -> hideLive meta $ viewSentMessage to context mc ts tz meta _ -> [] where to = if itemEdited then ttyToGroupEdited g else ttyToGroup g where - quote = maybe [] (groupQuote g) quotedItem + context = + maybe + (maybe [] forwardedFrom itemForwarded) + (groupQuote g) + quotedItem _ -> [] hideLive :: CIMeta c d -> [StyledString] -> [StyledString] @@ -778,6 +809,14 @@ directQuote _ CIQuote {content = qmc, chatDir = quoteDir} = groupQuote :: GroupInfo -> CIQuote 'CTGroup -> [StyledString] groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQuotedMember $ sentByMember g quoteDir +forwardedFrom :: CIForwardedFrom -> [StyledString] +forwardedFrom = \case + CIFFUnknown -> ["-> forwarded"] + CIFFContact c MDSnd _ _ -> ["<- you @" <> (plain . viewName) c] + CIFFContact c MDRcv _ _ -> ["<- @" <> (plain . viewName) c] + CIFFGroup g MDSnd _ _ -> ["<- you #" <> (plain . viewName) g] + CIFFGroup g MDRcv _ _ -> ["<- #" <> (plain . viewName) g] + sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember sentByMember GroupInfo {membership} = \case CIQGroupSnd -> Just membership @@ -836,7 +875,9 @@ viewChatCleared :: AChatInfo -> [StyledString] viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of DirectChat ct -> [ttyContact' ct <> ": all messages are removed locally ONLY"] GroupChat gi -> [ttyGroup' gi <> ": all messages are removed locally ONLY"] - _ -> [] + LocalChat _ -> ["notes: all messages are removed"] + ContactRequest _ -> [] + ContactConnection _ -> [] viewContactsList :: [Contact] -> [StyledString] viewContactsList = @@ -1484,17 +1525,17 @@ viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> Cu viewReceivedUpdatedMessage = viewReceivedMessage_ True viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString] -viewReceivedMessage_ updated from quote mc ts tz meta = receivedWithTime_ ts tz from quote meta (ttyMsgContent mc) updated +viewReceivedMessage_ updated from context mc ts tz meta = receivedWithTime_ ts tz from context meta (ttyMsgContent mc) updated viewReceivedReaction :: StyledString -> [StyledString] -> StyledString -> CurrentTime -> TimeZone -> UTCTime -> [StyledString] viewReceivedReaction from styledMsg reactionText ts tz reactionTs = prependFirst (ttyMsgTime ts tz reactionTs <> " " <> from) (styledMsg <> [" " <> reactionText]) receivedWithTime_ :: CurrentTime -> TimeZone -> StyledString -> [StyledString] -> CIMeta c d -> [StyledString] -> Bool -> [StyledString] -receivedWithTime_ ts tz from quote CIMeta {itemId, itemTs, itemEdited, itemDeleted, itemLive} styledMsg updated = do - prependFirst (ttyMsgTime ts tz itemTs <> " " <> from) (quote <> prependFirst (indent <> live) styledMsg) +receivedWithTime_ ts tz from context CIMeta {itemId, itemTs, itemEdited, itemDeleted, itemLive} styledMsg updated = do + prependFirst (ttyMsgTime ts tz itemTs <> " " <> from) (context <> prependFirst (indent <> live) styledMsg) where - indent = if null quote then "" else " " + indent = if null context then "" else " " live | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of @@ -1522,9 +1563,9 @@ recent now tz time = do || (localNow < currentDay12 && localTime >= previousDay18 && localTimeDay < localNowDay) viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString] -viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts tz (prependFirst to $ quote <> prependFirst (indent <> live) (ttyMsgContent mc)) meta +viewSentMessage to context mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts tz (prependFirst to $ context <> prependFirst (indent <> live) (ttyMsgContent mc)) meta where - indent = if null quote then "" else " " + indent = if null context then "" else " " live | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of @@ -1926,6 +1967,7 @@ viewChatError logLevel testView = \case CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"] CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."] CEInvalidQuote -> ["cannot reply to this message"] + CEInvalidForward -> ["cannot forward this message"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] CEHasCurrentCall -> ["call already in progress"] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 77d256a240..e8f3838eb6 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -3,6 +3,7 @@ module ChatTests where import ChatTests.ChatList import ChatTests.Direct import ChatTests.Files +import ChatTests.Forward import ChatTests.Groups import ChatTests.Local import ChatTests.Profiles @@ -11,6 +12,7 @@ import Test.Hspec hiding (it) chatTests :: SpecWith FilePath chatTests = do describe "direct tests" chatDirectTests + describe "forward tests" chatForwardTests describe "group tests" chatGroupTests describe "local chats tests" chatLocalChatsTests describe "file tests" chatFileTests diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index e50b20844a..572d9294a9 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -617,20 +617,8 @@ testXFTPWithRelativePaths = withXFTPServer $ do -- agent is passed xftp work directory only on chat start, -- so for test we work around by stopping and starting chat - alice ##> "/_stop" - alice <## "chat stopped" - alice #$> ("/_files_folder ./tests/fixtures", id, "ok") - alice #$> ("/_temp_folder ./tests/tmp/alice_xftp", id, "ok") - alice ##> "/_start" - alice <## "chat started" - - bob ##> "/_stop" - bob <## "chat stopped" - bob #$> ("/_files_folder ./tests/tmp/bob_files", id, "ok") - bob #$> ("/_temp_folder ./tests/tmp/bob_xftp", id, "ok") - bob ##> "/_start" - bob <## "chat started" - + setRelativePaths alice "./tests/fixtures" "./tests/tmp/alice_xftp" + setRelativePaths bob "./tests/tmp/bob_files" "./tests/tmp/bob_xftp" connectUsers alice bob alice #> "/f @bob test.pdf" diff --git a/tests/ChatTests/Forward.hs b/tests/ChatTests/Forward.hs new file mode 100644 index 0000000000..6aea8447b9 --- /dev/null +++ b/tests/ChatTests/Forward.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PostfixOperators #-} + +module ChatTests.Forward where + +import ChatClient +import ChatTests.Utils +import qualified Data.ByteString.Char8 as B +import System.Directory (copyFile, doesFileExist) +import Test.Hspec hiding (it) + +chatForwardTests :: SpecWith FilePath +chatForwardTests = do + describe "forward messages" $ do + it "from contact to contact" testForwardContactToContact + it "from contact to group" testForwardContactToGroup + it "from contact to notes" testForwardContactToNotes + it "from group to contact" testForwardGroupToContact + it "from group to group" testForwardGroupToGroup + it "from group to notes" testForwardGroupToNotes + it "from notes to contact" testForwardNotesToContact + it "from notes to group" testForwardNotesToGroup + it "from notes to notes" testForwardNotesToNotes -- TODO forward between different folders when supported + describe "interactions with forwarded messages" $ do + it "preserve original forward info" testForwardPreserveInfo + it "quoted message is not included" testForwardQuotedMsg + it "editing is prohibited" testForwardEditProhibited + describe "forward files" $ do + it "from contact to contact" testForwardFileNoFilesFolder + it "with relative paths: from contact to contact" testForwardFileContactToContact + it "with relative paths: from group to notes" testForwardFileGroupToNotes + it "with relative paths: from notes to group" testForwardFileNotesToGroup + +testForwardContactToContact :: HasCallStack => FilePath -> IO () +testForwardContactToContact = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + connectUsers alice bob + connectUsers alice cath + connectUsers bob cath + + alice #> "@bob hi" + bob <# "alice> hi" + msgId <- lastItemId alice + bob #> "@alice hey" + alice <# "bob> hey" + + alice ##> ("/_forward @3 @2 " <> msgId) + alice <# "@cath <- you @bob" + alice <## " hi" + cath <# "alice> -> forwarded" + cath <## " hi" + + alice `send` "@cath <- @bob hey" + alice <# "@cath <- @bob" + alice <## " hey" + cath <# "alice> -> forwarded" + cath <## " hey" + + -- read chat + alice ##> "/tail @cath 2" + alice <# "@cath <- you @bob" + alice <## " hi" + alice <# "@cath <- @bob" + alice <## " hey" + + cath ##> "/tail @alice 2" + cath <# "alice> -> forwarded" + cath <## " hi" + cath <# "alice> -> forwarded" + cath <## " hey" + + -- item info + alice ##> "/item info @cath hey" + alice <##. "sent at: " + alice <## "message history:" + alice .<## ": hey" + alice <##. "forwarded from: @bob, chat item id:" + +testForwardContactToGroup :: HasCallStack => FilePath -> IO () +testForwardContactToGroup = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + connectUsers alice bob + createGroup2 "team" alice cath + + alice #> "@bob hi" + bob <# "alice> hi" + bob #> "@alice hey" + alice <# "bob> hey" + + alice `send` "#team <- @bob hi" + alice <# "#team <- you @bob" + alice <## " hi" + cath <# "#team alice> -> forwarded" + cath <## " hi" + + alice `send` "#team <- @bob hey" + alice <# "#team <- @bob" + alice <## " hey" + cath <# "#team alice> -> forwarded" + cath <## " hey" + +testForwardContactToNotes :: HasCallStack => FilePath -> IO () +testForwardContactToNotes = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + createCCNoteFolder alice + connectUsers alice bob + + alice #> "@bob hi" + bob <# "alice> hi" + bob #> "@alice hey" + alice <# "bob> hey" + + alice `send` "* <- @bob hi" + alice <# "* <- you @bob" + alice <## " hi" + + alice `send` "* <- @bob hey" + alice <# "* <- @bob" + alice <## " hey" + +testForwardGroupToContact :: HasCallStack => FilePath -> IO () +testForwardGroupToContact = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup2 "team" alice bob + connectUsers alice cath + + alice #> "#team hi" + bob <# "#team alice> hi" + bob #> "#team hey" + alice <# "#team bob> hey" + + alice `send` "@cath <- #team hi" + alice <# "@cath <- you #team" + alice <## " hi" + cath <# "alice> -> forwarded" + cath <## " hi" + + alice `send` "@cath <- #team @bob hey" + alice <# "@cath <- #team" + alice <## " hey" + cath <# "alice> -> forwarded" + cath <## " hey" + +testForwardGroupToGroup :: HasCallStack => FilePath -> IO () +testForwardGroupToGroup = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup2 "team" alice bob + createGroup2 "club" alice cath + + alice #> "#team hi" + bob <# "#team alice> hi" + bob #> "#team hey" + alice <# "#team bob> hey" + + alice `send` "#club <- #team hi" + alice <# "#club <- you #team" + alice <## " hi" + cath <# "#club alice> -> forwarded" + cath <## " hi" + + alice `send` "#club <- #team hey" + alice <# "#club <- #team" + alice <## " hey" + cath <# "#club alice> -> forwarded" + cath <## " hey" + +testForwardGroupToNotes :: HasCallStack => FilePath -> IO () +testForwardGroupToNotes = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + createCCNoteFolder alice + createGroup2 "team" alice bob + + alice #> "#team hi" + bob <# "#team alice> hi" + bob #> "#team hey" + alice <# "#team bob> hey" + + alice `send` "* <- #team hi" + alice <# "* <- you #team" + alice <## " hi" + + alice `send` "* <- #team hey" + alice <# "* <- #team" + alice <## " hey" + +testForwardNotesToContact :: HasCallStack => FilePath -> IO () +testForwardNotesToContact = + testChat2 aliceProfile cathProfile $ + \alice cath -> do + createCCNoteFolder alice + connectUsers alice cath + + alice /* "hi" + + alice `send` "@cath <- * hi" + alice <# "@cath hi" + cath <# "alice> hi" + +testForwardNotesToGroup :: HasCallStack => FilePath -> IO () +testForwardNotesToGroup = + testChat2 aliceProfile cathProfile $ + \alice cath -> do + createCCNoteFolder alice + createGroup2 "team" alice cath + + alice /* "hi" + + alice `send` "#team <- * hi" + alice <# "#team hi" + cath <# "#team alice> hi" + +testForwardNotesToNotes :: HasCallStack => FilePath -> IO () +testForwardNotesToNotes tmp = + withNewTestChat tmp "alice" aliceProfile $ \alice -> do + createCCNoteFolder alice + + alice /* "hi" + + alice `send` "* <- * hi" + alice <# "* hi" + + alice ##> "/tail * 2" + alice <# "* hi" + alice <# "* hi" + +testForwardPreserveInfo :: HasCallStack => FilePath -> IO () +testForwardPreserveInfo = + testChat4 aliceProfile bobProfile cathProfile danProfile $ + \alice bob cath dan -> do + createCCNoteFolder alice + connectUsers alice bob + connectUsers alice cath + createGroup2 "team" alice dan + + bob #> "@alice hey" + alice <# "bob> hey" + + alice `send` "* <- @bob hey" + alice <# "* <- @bob" + alice <## " hey" + + alice `send` "@cath <- * hey" + alice <# "@cath <- @bob" + alice <## " hey" + cath <# "alice> -> forwarded" + cath <## " hey" + + alice `send` "#team <- @cath hey" + alice <# "#team <- @bob" + alice <## " hey" + dan <# "#team alice> -> forwarded" + dan <## " hey" + +testForwardQuotedMsg :: HasCallStack => FilePath -> IO () +testForwardQuotedMsg = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + connectUsers alice bob + connectUsers alice cath + + alice #> "@bob hi" + bob <# "alice> hi" + bob `send` "> @alice (hi) hey" + bob <# "@alice > hi" + bob <## " hey" + alice <# "bob> > hi" + alice <## " hey" + + alice `send` "@cath <- @bob hey" + alice <# "@cath <- @bob" + alice <## " hey" + cath <# "alice> -> forwarded" + cath <## " hey" + + -- read chat + alice ##> "/tail @cath 1" + alice <# "@cath <- @bob" + alice <## " hey" + + cath ##> "/tail @alice 1" + cath <# "alice> -> forwarded" + cath <## " hey" + +testForwardEditProhibited :: HasCallStack => FilePath -> IO () +testForwardEditProhibited = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + connectUsers alice bob + connectUsers alice cath + + bob #> "@alice hey" + alice <# "bob> hey" + + alice `send` "@cath <- @bob hey" + alice <# "@cath <- @bob" + alice <## " hey" + cath <# "alice> -> forwarded" + cath <## " hey" + + msgId <- lastItemId alice + alice ##> ("/_update item @3 " <> msgId <> " text hey edited") + alice <## "cannot update this item" + +testForwardFileNoFilesFolder :: HasCallStack => FilePath -> IO () +testForwardFileNoFilesFolder = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> withXFTPServer $ do + connectUsers alice bob + connectUsers bob cath + + -- send original file + alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice <# "@bob hi" + alice <# "/f @bob ./tests/fixtures/test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "alice> hi" + bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + + bob ##> "/fr 1 ./tests/tmp" + concurrentlyN_ + [ alice <## "completed uploading file 1 (test.pdf) for bob", + bob + <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + "started receiving file 1 (test.pdf) from alice" + ] + ] + bob <## "completed receiving file 1 (test.pdf) from alice" + + src <- B.readFile "./tests/fixtures/test.pdf" + dest <- B.readFile "./tests/tmp/test.pdf" + dest `shouldBe` src + + -- forward file + bob `send` "@cath <- @alice hi" + bob <# "@cath <- @alice" + bob <## " hi" + bob <# "/f @cath ./tests/tmp/test.pdf" + bob <## "use /fc 2 to cancel sending" + cath <# "bob> -> forwarded" + cath <## " hi" + cath <# "bob> sends file test.pdf (266.0 KiB / 272376 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + + cath ##> "/fr 1 ./tests/tmp" + concurrentlyN_ + [ bob <## "completed uploading file 2 (test.pdf) for cath", + cath + <### [ "saving file 1 from bob to ./tests/tmp/test_1.pdf", + "started receiving file 1 (test.pdf) from bob" + ] + ] + cath <## "completed receiving file 1 (test.pdf) from bob" + + dest2 <- B.readFile "./tests/tmp/test_1.pdf" + dest2 `shouldBe` src + +testForwardFileContactToContact :: HasCallStack => FilePath -> IO () +testForwardFileContactToContact = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> withXFTPServer $ do + setRelativePaths alice "./tests/fixtures" "./tests/tmp/alice_xftp" + setRelativePaths bob "./tests/tmp/bob_files" "./tests/tmp/bob_xftp" + setRelativePaths cath "./tests/tmp/cath_files" "./tests/tmp/cath_xftp" + connectUsers alice bob + connectUsers bob cath + + -- send original file + alice ##> "/_send @2 json {\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice <# "@bob hi" + alice <# "/f @bob test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "alice> hi" + bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + + bob ##> "/fr 1" + concurrentlyN_ + [ alice <## "completed uploading file 1 (test.pdf) for bob", + bob + <### [ "saving file 1 from alice to test.pdf", + "started receiving file 1 (test.pdf) from alice" + ] + ] + bob <## "completed receiving file 1 (test.pdf) from alice" + + src <- B.readFile "./tests/fixtures/test.pdf" + dest <- B.readFile "./tests/tmp/bob_files/test.pdf" + dest `shouldBe` src + + -- forward file + bob `send` "@cath <- @alice hi" + bob <# "@cath <- @alice" + bob <## " hi" + bob <# "/f @cath test_1.pdf" + bob <## "use /fc 2 to cancel sending" + cath <# "bob> -> forwarded" + cath <## " hi" + cath <# "bob> sends file test_1.pdf (266.0 KiB / 272376 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + + cath ##> "/fr 1" + concurrentlyN_ + [ bob <## "completed uploading file 2 (test_1.pdf) for cath", + cath + <### [ "saving file 1 from bob to test_1.pdf", + "started receiving file 1 (test_1.pdf) from bob" + ] + ] + cath <## "completed receiving file 1 (test_1.pdf) from bob" + + src2 <- B.readFile "./tests/tmp/bob_files/test_1.pdf" + src2 `shouldBe` dest + dest2 <- B.readFile "./tests/tmp/cath_files/test_1.pdf" + dest2 `shouldBe` src2 + + -- deleting original file doesn't delete forwarded file + checkActionDeletesFile "./tests/tmp/bob_files/test.pdf" $ do + bob ##> "/clear alice" + bob <## "alice: all messages are removed locally ONLY" + fwdFileExists <- doesFileExist "./tests/tmp/bob_files/test_1.pdf" + fwdFileExists `shouldBe` True + +testForwardFileGroupToNotes :: HasCallStack => FilePath -> IO () +testForwardFileGroupToNotes = + testChat2 aliceProfile cathProfile $ + \alice cath -> withXFTPServer $ do + setRelativePaths alice "./tests/fixtures" "./tests/tmp/alice_xftp" + setRelativePaths cath "./tests/tmp/cath_files" "./tests/tmp/cath_xftp" + createGroup2 "team" alice cath + createCCNoteFolder cath + + -- send original file + alice ##> "/_send #1 json {\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice <# "#team hi" + alice <# "/f #team test.pdf" + alice <## "use /fc 1 to cancel sending" + cath <# "#team alice> hi" + cath <# "#team alice> sends file test.pdf (266.0 KiB / 272376 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + + cath ##> "/fr 1" + concurrentlyN_ + [ alice <## "completed uploading file 1 (test.pdf) for #team", + cath + <### [ "saving file 1 from alice to test.pdf", + "started receiving file 1 (test.pdf) from alice" + ] + ] + cath <## "completed receiving file 1 (test.pdf) from alice" + + src <- B.readFile "./tests/fixtures/test.pdf" + dest <- B.readFile "./tests/tmp/cath_files/test.pdf" + dest `shouldBe` src + + -- forward file + cath `send` "* <- #team hi" + cath <# "* <- #team" + cath <## " hi" + cath <# "* file 2 (test_1.pdf)" + + dest2 <- B.readFile "./tests/tmp/cath_files/test_1.pdf" + dest2 `shouldBe` dest + + -- deleting original file doesn't delete forwarded file + checkActionDeletesFile "./tests/tmp/cath_files/test.pdf" $ do + cath ##> "/clear #team" + cath <## "#team: all messages are removed locally ONLY" + fwdFileExists <- doesFileExist "./tests/tmp/cath_files/test_1.pdf" + fwdFileExists `shouldBe` True + +testForwardFileNotesToGroup :: HasCallStack => FilePath -> IO () +testForwardFileNotesToGroup = + testChat2 aliceProfile cathProfile $ + \alice cath -> withXFTPServer $ do + setRelativePaths alice "./tests/tmp/alice_files" "./tests/tmp/alice_xftp" + setRelativePaths cath "./tests/tmp/cath_files" "./tests/tmp/cath_xftp" + copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_files/test.pdf" + createCCNoteFolder alice + createGroup2 "team" alice cath + + -- create original file + alice ##> "/_create *1 json {\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice <# "* hi" + alice <# "* file 1 (test.pdf)" + + -- forward file + alice `send` "#team <- * hi" + alice <# "#team hi" + alice <# "/f #team test_1.pdf" + alice <## "use /fc 2 to cancel sending" + cath <# "#team alice> hi" + cath <# "#team alice> sends file test_1.pdf (266.0 KiB / 272376 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + + cath ##> "/fr 1" + concurrentlyN_ + [ alice <## "completed uploading file 2 (test_1.pdf) for #team", + cath + <### [ "saving file 1 from alice to test_1.pdf", + "started receiving file 1 (test_1.pdf) from alice" + ] + ] + cath <## "completed receiving file 1 (test_1.pdf) from alice" + + src <- B.readFile "./tests/tmp/alice_files/test.pdf" + src2 <- B.readFile "./tests/tmp/alice_files/test_1.pdf" + src2 `shouldBe` src + dest2 <- B.readFile "./tests/tmp/cath_files/test_1.pdf" + dest2 `shouldBe` src2 + + -- deleting original file doesn't delete forwarded file + checkActionDeletesFile "./tests/tmp/alice_files/test.pdf" $ do + alice ##> "/clear *" + alice <## "notes: all messages are removed" + fwdFileExists <- doesFileExist "./tests/tmp/alice_files/test_1.pdf" + fwdFileExists `shouldBe` True diff --git a/tests/ChatTests/Local.hs b/tests/ChatTests/Local.hs index 40ebe51b83..5562d517ac 100644 --- a/tests/ChatTests/Local.hs +++ b/tests/ChatTests/Local.hs @@ -150,6 +150,7 @@ testFiles tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do doesFileExist stored `shouldReturn` True alice ##> "/clear *" + alice <## "notes: all messages are removed" alice ##> "/fs 1" alice <## "file 1 not found" alice ##> "/tail" @@ -180,6 +181,7 @@ testOtherFiles = bob ##> "/tail *" bob <# "* test" bob ##> "/clear *" + bob <## "notes: all messages are removed" bob ##> "/tail *" bob ##> "/fs 1" bob <## "receiving file 1 (test.jpg) complete, path: test.jpg" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 98227fcd0c..aa6579efee 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -723,3 +723,12 @@ linkAnotherSchema link xftpCLI :: [String] -> IO [String] xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI) + +setRelativePaths :: HasCallStack => TestCC -> String -> String -> IO () +setRelativePaths cc filesFolder tempFolder = do + cc ##> "/_stop" + cc <## "chat stopped" + cc #$> ("/_files_folder " <> filesFolder, id, "ok") + cc #$> ("/_temp_folder " <> tempFolder, id, "ok") + cc ##> "/_start" + cc <## "chat started"