wip

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 =

src/Simplex/Chat/Controller.hs

@@ -1114,6 +1114,7 @@ data ChatErrorType
   | CEFallbackToSMPProhibited {fileId :: FileTransferId}
   | CEInlineFileProhibited {fileId :: FileTransferId}
   | CEInvalidQuote
+  | CEInvalidForward
   | CEInvalidChatItemUpdate
   | CEInvalidChatItemDelete
   | CEHasCurrentCall

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

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)

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"]