lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

core: api to forward messages (#3968)

Browse source 
* wip

* wip

* test

* mute

* tests

* simplify (only bool flag)

* re-encrypt file

* tests

* more tests (wip)

* fix relative paths, refactor

* more tests

* more locks

* fix, tests

* more tests

* rework (revert from bool to ids)

* update schema

* more tests

* add to info

* ForwardedMsg container

* Revert "ForwardedMsg container"

This reverts commit bb57f12151.

* parser

* more tests

* rework api

* more locks

* test

* move

* remove from

* view

* prohibit editing

* item info view

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2024-04-09 13:02:59 +01:00 • committed by GitHub
parent f8e6a78a3b
commit a5db36469d
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
17 changed files with 1061 additions and 211 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
simplex-chat.cabal
View file

@ -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

393
src/Simplex/Chat.hs
View file

@ -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),

5
src/Simplex/Chat/Controller.hs
View file

@ -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

69
src/Simplex/Chat/Messages.hs
View file

@ -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

2
src/Simplex/Chat/Messages/CIContent.hs
View file

@ -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

36
src/Simplex/Chat/Migrations/M20240402_item_forwarded.hs Normal file
View file

@ -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;
|]

15
src/Simplex/Chat/Migrations/chat_schema.sql
View file

@ -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
);

1
src/Simplex/Chat/Protocol.hs
View file

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

86
src/Simplex/Chat/Store/Messages.hs
View file

@ -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

4
src/Simplex/Chat/Store/Migrations.hs
View file

@ -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

3
src/Simplex/Chat/Terminal/Input.hs
View file

@ -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 ()

104
src/Simplex/Chat/View.hs
View file

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

2
tests/ChatTests.hs
View file

@ -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

16
tests/ChatTests/Files.hs
View file

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

523
tests/ChatTests/Forward.hs Normal file
View file

@ -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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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

2
tests/ChatTests/Local.hs
View file

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

9
tests/ChatTests/Utils.hs
View file

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