diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 9799a59eae..60907ec3f6 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -822,15 +822,79 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") - APIForwardChatItem _fromChatRef toChatRef@(ChatRef toCType _) _chatItemId -> withUser $ \user -> withChatLock "forwardChatItem" $ case toCType of + APIForwardChatItem (ChatRef fromCType fromChatId) (ChatRef toCType toChatId) itemId -> withUser $ \user -> withChatLock "forwardChatItem" $ case toCType of CTDirect -> do - pure $ chatCmdError (Just user) "not implemented" + (cm, ciff) <- prepareForward user + sendContactContentMessage user toChatId False Nothing cm (Just ciff) CTGroup -> do - pure $ chatCmdError (Just user) "not implemented" + (cm, ciff) <- prepareForward user + sendGroupContentMessage user toChatId False Nothing cm (Just ciff) CTLocal -> do - pure $ chatCmdError (Just user) "not implemented" + (cm, ciff) <- prepareForward user + createNoteFolderContentItem user toChatId cm (Just ciff) CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + prepareForward :: User -> CM (ComposedMessage, CIForwardedFrom) + prepareForward user = case fromCType of + CTDirect -> do + (ct, CChatItem _ ci) <- withStore $ \db -> do + ct <- getContact db vr user fromChatId + cci <- getDirectChatItem db user fromChatId itemId + pure (ct, cci) + mc <- forwardMC ci + file <- forwardCryptoFile ci + let ciff = forwardCIFF ci $ CIFFContact (forwardName ct) fromChatId + pure (ComposedMessage file Nothing mc, ciff) + where + forwardName :: Contact -> ContactName + forwardName Contact {profile = LocalProfile {displayName, localAlias}} + | localAlias /= "" = localAlias + | otherwise = displayName + CTGroup -> do + (gInfo, CChatItem _ ci) <- withStore $ \db -> do + gInfo <- getGroupInfo db vr user fromChatId + cci <- getGroupChatItem db user fromChatId itemId + pure (gInfo, cci) + mc <- forwardMC ci + file <- forwardCryptoFile ci + let ciff = forwardCIFF ci $ CIFFGroup (forwardName gInfo) fromChatId + 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 + let ciff = forwardCIFF ci $ CIFFNoteFolder "notes" fromChatId + pure (ComposedMessage file Nothing mc, ciff) + CTContactRequest -> throwChatError $ CECommandError "not supported" + CTContactConnection -> throwChatError $ CECommandError "not supported" + where + forwardMC :: ChatItem c d -> CM MsgContent + forwardMC ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidForward + forwardMC ChatItem {content = CISndMsgContent fmc} = pure fmc + forwardMC ChatItem {content = CIRcvMsgContent fmc} = pure fmc + forwardMC _ = throwChatError CEInvalidForward + forwardCIFF :: ChatItem c d -> CIForwardedFrom -> CIForwardedFrom + forwardCIFF ChatItem {meta = CIMeta {itemForwarded = Just ciff}} _ = ciff + forwardCIFF _ ciff = ciff + forwardCryptoFile :: ChatItem c d -> CM (Maybe CryptoFile) + forwardCryptoFile ChatItem {file = Just CIFile {fileName, fileSource = Just cf@CryptoFile {filePath}}} = + chatReadVar filesFolder >>= \case + Nothing -> + ifM (doesFileExist filePath) (pure $ Just cf) (pure Nothing) + Just filesFolder -> + ifM + (doesFileExist filePath) + ( do + fPath <- liftIO $ filesFolder `uniqueCombine` fileName + liftIO $ copyFile filePath fPath -- to keep forwarded file in case original is deleted + pure $ Just (cf {filePath = fPath} :: CryptoFile) + ) + (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 @@ -2196,8 +2260,9 @@ processChatCommand' vr = \case -- [incognito] filter out contacts with whom user has incognito connections addChangedProfileContact :: User -> Contact -> [ChangedProfileContact] -> [ChangedProfileContact] addChangedProfileContact user' ct changedCts = case contactSendConn_ ct' of - Right conn | not (connIncognito conn) && mergedProfile' /= mergedProfile -> - ChangedProfileContact ct ct' mergedProfile' conn : changedCts + Right conn + | not (connIncognito conn) && mergedProfile' /= mergedProfile -> + ChangedProfileContact ct ct' mergedProfile' conn : changedCts _ -> changedCts where mergedProfile = userProfileToSend user Nothing (Just ct) False @@ -3628,7 +3693,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- probably this branch is never executed, so there should be no reason -- to save message if contact hasn't been created yet - chat item isn't created anyway withAckMessage' agentConnId meta $ - void $ saveDirectRcvMSG conn meta msgBody + void $ + saveDirectRcvMSG conn meta msgBody SENT msgId -> sentMsgDeliveryEvent conn msgId OK -> @@ -4464,9 +4530,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- This prevents losing the message that failed to be processed. Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing Left e -> ackMsg msgMeta Nothing >> throwError e - where - ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM () - ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt + where + ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM () + ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM () sentMsgDeliveryEvent Connection {connId} msgId = diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 5ce877ef80..46e6925a05 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -1114,6 +1114,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 6c5282e084..687fc3c514 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -985,9 +985,9 @@ itemDeletedTs = \case data CIForwardedFrom = CIFFUnknown - | CIFFContact {name :: String, contactId :: ContactId} - | CIFFGroup {name :: String, groupId :: GroupId} - | CIFFNoteFolder {name :: String, folderId :: NoteFolderId} + | CIFFContact {name :: Text, contactId :: ContactId} + | CIFFGroup {name :: Text, groupId :: GroupId} + | CIFFNoteFolder {name :: Text, folderId :: NoteFolderId} deriving (Show) cmForwardedFrom :: AChatMsgEvent -> Maybe CIForwardedFrom diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index c676422e41..16dd8ea2b6 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -402,7 +402,7 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing, Nothing) CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId) CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId) - forwardedFromRow :: (Maybe String, Maybe Int64, Maybe Int64, Maybe Int64) + forwardedFromRow :: (Maybe Text, Maybe Int64, Maybe Int64, Maybe Int64) forwardedFromRow = case itemForwarded of Nothing -> (Nothing, Nothing, Nothing, Nothing) Just CIFFUnknown -> (Just "", Nothing, Nothing, Nothing) @@ -1402,7 +1402,7 @@ type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) -type ChatItemForwardedFromRow = (Maybe String, Maybe Int64, Maybe Int64, Maybe Int64) +type ChatItemForwardedFromRow = (Maybe Text, Maybe Int64, Maybe Int64, Maybe Int64) type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 65a6626308..38cbfdec16 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -534,60 +534,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 @@ -602,10 +610,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 @@ -664,37 +672,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] @@ -776,6 +792,13 @@ 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 _ -> ["-> forwarded from " <> ttyContact c] + CIFFGroup g _ -> ["-> forwarded from " <> ttyGroup g] + CIFFNoteFolder _ _ -> ["-> forwarded from notes"] + sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember sentByMember GroupInfo {membership} = \case CIQGroupSnd -> Just membership @@ -1482,17 +1505,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 @@ -1520,9 +1543,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 @@ -1595,7 +1618,7 @@ standaloneUploadComplete FileTransferMeta {fileId, fileName} = \case [] -> [fileTransferStr fileId fileName <> " upload complete."] uris -> fileTransferStr fileId fileName <> " upload complete. download with:" - : map plain uris + : map plain uris sndFile :: SndFileTransfer -> StyledString sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName @@ -1924,6 +1947,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"]