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: support batch sending in groups, batch introductions; send recent message history to new members (#3519)

Browse source 
* core: batch send stubs, comments

* multiple events in ChatMessage and supporting types

* Revert "multiple events in ChatMessage and supporting types"

This reverts commit 9b239b26ba.

* schema, refactor group processing for batched messages

* encoding, refactor processing

* refactor code to work with updated schema

* encoding, remove instances

* wip

* implement batching

* batch introductions

* wip

* collect and send message history

* missing new line

* rename

* test

* rework to build history via chat items

* refactor, tests

* correctly set member version range, dont include deleted items

* tests

* fix disappearing messages

* check number of errors

* comment

* check size in encodeChatMessage

* fix - don't check msg size for binary

* use builder

* rename

* rename

* rework batching

* lazy msg body

* use withStoreBatch

* refactor

* reverse batches

* comment

* possibly fix builder for single msg

* refactor batcher

* refactor

* dont repopulate msg_deliveries on down migration

* EncodedChatMessage type

* remove type

* batcher tests

* add tests

* group history preference

* test group link

* fix tests

* fix for random update

* add test testImageFitsSingleBatch

* refactor

* rename function

* refactor

* mconcat

* rename feature

* catch error on each batch

* refactor file inv retrieval

* refactor gathering item forward events

* refactor message batching

* unite migrations

* move files

* refactor

* Revert "unite migrations"

This reverts commit 0be7a3117a.

* refactor splitFileDescr

* improve tests

* Revert "dont repopulate msg_deliveries on down migration"

This reverts commit 2944c1cc28.

* fix down migration

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
spaced4ndy 2023-12-23 17:07:23 +04:00 • committed by GitHub
parent f93f68e425
commit 12d1ada25e
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
25 changed files with 1616 additions and 343 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
simplex-chat.cabal
View file

@ -36,6 +36,7 @@ library
Simplex.Chat.Help
Simplex.Chat.Markdown
Simplex.Chat.Messages
Simplex.Chat.Messages.Batch
Simplex.Chat.Messages.CIContent
Simplex.Chat.Messages.CIContent.Events
Simplex.Chat.Migrations.M20220101_initial
@ -127,6 +128,7 @@ library
Simplex.Chat.Migrations.M20231126_remote_ctrl_address
Simplex.Chat.Migrations.M20231207_chat_list_pagination
Simplex.Chat.Migrations.M20231214_item_content_tag
Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared
@ -543,6 +545,7 @@ test-suite simplex-chat-test
ChatTests.Utils
JSONTests
MarkdownTests
MessageBatching
MobileTests
ProtocolTests
RemoteTests

449
src/Simplex/Chat.hs
View file

@ -29,6 +29,7 @@ import Data.Bifunctor (bimap, first)
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
@ -38,20 +39,19 @@ import Data.Either (fromRight, lefts, partitionEithers, rights)
import Data.Fixed (div')
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, foldl', isSuffixOf, partition, sortBy, sortOn)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.List (find, foldl', isSuffixOf, partition, sortOn)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
import Data.Ord (comparing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds)
import Data.Time.Clock.System (systemToUTCTime)
import Data.Word (Word16, Word32)
import Data.Word (Word32)
import qualified Database.SQLite.Simple as SQL
import Simplex.Chat.Archive
import Simplex.Chat.Call
@ -59,6 +59,7 @@ import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Options
@ -77,7 +78,7 @@ import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Util
import Simplex.Chat.Util (encryptFile)
import Simplex.Chat.Util (encryptFile, shuffle)
import Simplex.FileTransfer.Client.Main (maxFileSize)
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb)
@ -607,7 +608,7 @@ processChatCommand = \case
<$> withConnection st (readTVarIO . DB.slow)
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user pendingConnections pagination query)
toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
-- TODO optimize queries calculating ChatStats, currently they're disabled
@ -688,7 +689,7 @@ processChatCommand = \case
withStore $ \db -> getDirectChatItem db user chatId quotedItemId
(origQmc, qd, sent) <- quoteData qci
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
qmc = quoteContent origQmc file
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
@ -702,13 +703,13 @@ processChatCommand = \case
assertUserGroupRole gInfo GRAuthor
send g
where
send g@(Group gInfo@GroupInfo {groupId, membership} ms)
send g@(Group gInfo@GroupInfo {groupId} ms)
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
| otherwise = do
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership
(msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ timed_ live
(msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
withStore' $ \db ->
@ -748,51 +749,9 @@ processChatCommand = \case
void . withStore' $ \db -> createSndGroupInlineFT db m conn ft
sendMemberFileInline m conn ft sharedMsgId
processMember _ = pure ()
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
prepareMsg fInv_ timed_ membership = 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 -> getGroupChatItem db user chatId quotedItemId
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
qmc = quoteContent 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 -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership')
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
quoteData _ _ = throwChatError CEInvalidQuote
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
where
quoteContent :: forall d. MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent qmc ciFile_
| replaceContent = MCText qTextOrFile
| otherwise = case qmc of
MCImage _ image -> MCImage qTextOrFile image
MCFile _ -> MCFile qTextOrFile
-- consider same for voice messages
-- MCVoice _ voice -> MCVoice qTextOrFile voice
_ -> qmc
where
-- if the message we're quoting with is one of the "large" MsgContents
-- we replace the quote's content with MCText
replaceContent = case mc of
MCText _ -> False
MCFile _ -> False
MCLink {} -> True
MCImage {} -> True
MCVideo {} -> True
MCVoice {} -> False
MCUnknown {} -> True
qText = msgContentText qmc
getFileName :: CIFile d -> String
getFileName CIFile {fileName} = fileName
qFileName = maybe qText (T.pack . getFileName) ciFile_
qTextOrFile = if T.null qText then qFileName else qText
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
let fileName = takeFileName filePath
@ -1836,7 +1795,7 @@ processChatCommand = \case
LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user False (PTLast count) clqNoFilters)
toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do
chatRef <- getChatRef user chatName
@ -2307,7 +2266,7 @@ processChatCommand = \case
tryChatError (withStore (`getUser` userId)) >>= \case
Left _ -> throwChatError CEUserUnknown
Right user -> pure user
validateUserPassword :: User -> User -> Maybe UserPwd -> m ()
validateUserPassword :: User -> User -> Maybe UserPwd -> m ()
validateUserPassword = validateUserPassword_ . Just
validateUserPassword_ :: Maybe User -> User -> Maybe UserPwd -> m ()
validateUserPassword_ user_ User {userId = userId', viewPwdHash} viewPwd_ =
@ -2433,6 +2392,50 @@ processChatCommand = \case
cReqHashes = bimap hash hash cReqSchemas
hash = ConnReqUriHash . C.sha256Hash . strEncode
prepareGroupMsg :: forall m. ChatMonad m => User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe FileInvitation -> Maybe CITimed -> Bool -> m (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
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
withStore $ \db -> getGroupChatItem db user groupId quotedItemId
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
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 -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership')
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
quoteData _ _ = throwChatError CEInvalidQuote
quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent mc qmc ciFile_
| replaceContent = MCText qTextOrFile
| otherwise = case qmc of
MCImage _ image -> MCImage qTextOrFile image
MCFile _ -> MCFile qTextOrFile
-- consider same for voice messages
-- MCVoice _ voice -> MCVoice qTextOrFile voice
_ -> qmc
where
-- if the message we're quoting with is one of the "large" MsgContents
-- we replace the quote's content with MCText
replaceContent = case mc of
MCText _ -> False
MCFile _ -> False
MCLink {} -> True
MCImage {} -> True
MCVideo {} -> True
MCVoice {} -> False
MCUnknown {} -> True
qText = msgContentText qmc
getFileName :: CIFile d -> String
getFileName CIFile {fileName} = fileName
qFileName = maybe qText (T.pack . getFileName) ciFile_
qTextOrFile = if T.null qText then qFileName else qText
assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m ()
assertDirectAllowed user dir ct event =
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
@ -2610,7 +2613,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
-- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db user fileId filePath
rfd <- getRcvFileDescrByFileId db fileId
rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd cryptoArgs
pure ci
@ -3188,17 +3191,29 @@ processAgentMsgSndFile _corrId aFileId msg =
sendFileDescription sft rfd msgId sendMsg = do
let rfdText = fileDescrText rfd
withStore' $ \db -> updateSndFTDescrXFTP db user sft rfdText
partSize <- asks $ xftpDescrPartSize . config
sendParts 1 partSize rfdText
parts <- splitFileDescr rfdText
loopSend parts
where
sendParts partNo partSize rfdText = do
let (part, rest) = T.splitAt partSize rfdText
complete = T.null rest
fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
-- returns msgDeliveryId of the last file description message
loopSend :: NonEmpty FileDescr -> m Int64
loopSend (fileDescr :| fds) = do
(_, msgDeliveryId) <- sendMsg $ XMsgFileDescr {msgId, fileDescr}
if complete
then pure msgDeliveryId
else sendParts (partNo + 1) partSize rest
case L.nonEmpty fds of
Just fds' -> loopSend fds'
Nothing -> pure msgDeliveryId
splitFileDescr :: ChatMonad m => RcvFileDescrText -> m (NonEmpty FileDescr)
splitFileDescr rfdText = do
partSize <- asks $ xftpDescrPartSize . config
pure $ splitParts 1 partSize rfdText
where
splitParts partNo partSize remText =
let (part, rest) = T.splitAt partSize remText
complete = T.null rest
fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
in if complete
then fileDescr :| []
else fileDescr <| splitParts (partNo + 1) partSize rest
processAgentMsgRcvFile :: forall m. ChatMonad m => ACorrId -> RcvFileId -> ACommand 'Agent 'AERcvFile -> m ()
processAgentMsgRcvFile _corrId aFileId msg =
@ -3293,6 +3308,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
pure ()
MSG meta _msgFlags msgBody -> do
cmdId <- createAckCmd conn
-- TODO only acknowledge without saving message?
-- probably this branch is never executed, so there should be no reason
-- to save message if contact hasn't been created yet - chat item isn't created anyway
withAckMessage agentConnId cmdId meta $ do
(_conn', _) <- saveDirectRcvMSG conn meta cmdId msgBody
pure False
@ -3568,21 +3586,105 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let Connection {viaUserContactLink} = conn
when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem
members <- withStore' $ \db -> getGroupMembers db user gInfo
intros <- withStore' $ \db -> createIntroductions db members m
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
shuffledIntros <- liftIO $ shuffleMembers intros $ \GroupMemberIntro {reMember = GroupMember {memberRole}} -> memberRole
forM_ shuffledIntros $ \intro ->
processIntro intro `catchChatError` (toView . CRChatError (Just user))
sendIntroductions members
when (groupFeatureAllowed SGFHistory gInfo) sendHistory
where
sendXGrpLinkMem = do
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
profileToSend = profileToSendOnAccept user profileMode
void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId)
sendIntroductions members = do
intros <- withStore' $ \db -> createIntroductions db members m
shuffledIntros <- liftIO $ shuffleIntros intros
if isCompatibleRange (memberChatVRange' m) batchSendVRange
then do
let events = map (XGrpMemIntro . memberInfo . reMember) shuffledIntros
forM_ (L.nonEmpty events) $ \events' ->
sendGroupMemberMessages user conn events' groupId
else forM_ shuffledIntros $ \intro ->
processIntro intro `catchChatError` (toView . CRChatError (Just user))
shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro]
shuffleIntros intros = do
let (admins, others) = partition isAdmin intros
(admPics, admNoPics) = partition hasPicture admins
(othPics, othNoPics) = partition hasPicture others
mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics]
where
isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin
hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image
processIntro intro@GroupMemberIntro {introId} = do
void $ sendDirectMessage conn (XGrpMemIntro $ memberInfo (reMember intro)) (GroupId groupId)
withStore' $ \db -> updateIntroStatus db introId GMIntroSent
sendHistory =
when (isCompatibleRange (memberChatVRange' m) batchSendVRange) $ do
(errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo 100)
(errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items
let errors = map ChatErrorStore errs <> errs'
unless (null errors) $ toView $ CRChatErrors (Just user) errors
forM_ (L.nonEmpty $ concat events) $ \events' ->
sendGroupMemberMessages user conn events' groupId
itemForwardEvents :: CChatItem 'CTGroup -> m [ChatMsgEvent 'Json]
itemForwardEvents cci = case cci of
(CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) -> do
fInvDescr_ <- join <$> forM file getRcvFileInvDescr
processContentItem sender ci mc fInvDescr_
(CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do
fInvDescr_ <- join <$> forM file getSndFileInvDescr
processContentItem membership ci mc fInvDescr_
_ -> pure []
where
getRcvFileInvDescr :: CIFile 'MDRcv -> m (Maybe (FileInvitation, RcvFileDescrText))
getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do
expired <- fileExpired
if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired
then pure Nothing
else do
rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId
pure $ invCompleteDescr ciFile rfd
getSndFileInvDescr :: CIFile 'MDSnd -> m (Maybe (FileInvitation, RcvFileDescrText))
getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do
expired <- fileExpired
if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired
then pure Nothing
else do
-- can also lookup in extra_xftp_file_descriptions, though it can be empty;
-- would be best if snd file had a single rcv description for all members saved in files table
rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId
pure $ invCompleteDescr ciFile rfd
fileExpired :: m Bool
fileExpired = do
ttl <- asks $ rcvFilesTTL . agentConfig . config
cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime
pure $ chatItemTs cci < cutoffTs
invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText)
invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete}
| fileDescrComplete =
let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
fInv = xftpFileInvitation fileName fileSize fInvDescr
in Just (fInv, fileDescrText)
| otherwise = Nothing
processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> m [ChatMsgEvent Json]
processContentItem sender ChatItem {meta, quotedItem} mc fInvDescr_ =
if isNothing fInvDescr_ && not (msgContentHasText mc)
then pure []
else do
let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta
quotedItemId_ = quoteItemId =<< quotedItem
fInv_ = fst <$> fInvDescr_
(msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ itemTimed False
let senderVRange = memberChatVRange' sender
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer}
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
(Just fileDescrText, Just msgId) -> do
parts <- splitFileDescr fileDescrText
pure . toList $ L.map (XMsgFileDescr msgId) parts
_ -> pure []
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
GroupMember {memberId} = sender
msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs)
pure msgForwardEvents
_ -> do
-- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table
let memCategory = memberCategory m
withStore' (\db -> getViaGroupContact db user m) >>= \case
Nothing -> do
@ -3610,41 +3712,27 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
void $ sendDirectMessage imConn (XGrpMemCon m.memberId) (GroupId groupId)
_ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
MSG msgMeta _msgFlags msgBody -> do
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure ()
cmdId <- createAckCmd conn
tryChatError (processChatMessage cmdId) >>= \case
Right (ACMsg _ chatMsg, withRcpt) -> do
ackMsg agentConnId cmdId msgMeta $ if withRcpt then Just "" else Nothing
when (membership.memberRole >= GRAdmin) $ forwardMsg_ chatMsg
Left e -> ackMsg agentConnId cmdId msgMeta Nothing >> throwError e
let aChatMsgs = parseChatMessages msgBody
withAckMessage agentConnId cmdId msgMeta $ do
forM_ aChatMsgs $ \case
Right (ACMsg _ chatMsg) ->
processEvent cmdId chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e
Left e -> toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
checkSendRcpt $ rights aChatMsgs
-- currently only a single message is forwarded
when (membership.memberRole >= GRAdmin) $ case aChatMsgs of
[Right (ACMsg _ chatMsg)] -> forwardMsg_ chatMsg
_ -> pure ()
where
processChatMessage :: Int64 -> m (AChatMessage, Bool)
processChatMessage cmdId = do
msg@(ACMsg _ chatMsg) <- parseAChatMessage conn msgMeta msgBody
checkIntegrity chatMsg `catchChatError` \_ -> pure ()
(msg,) <$> processEvent cmdId chatMsg
brokerTs = metaBrokerTs msgMeta
checkIntegrity :: ChatMessage e -> m ()
checkIntegrity ChatMessage {chatMsgEvent} = do
when checkForEvent $ checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
where
checkForEvent = case chatMsgEvent of
XMsgNew _ -> True
XFileCancel _ -> True
XFileAcptInv {} -> True
XGrpMemNew _ -> True
XGrpMemRole {} -> True
XGrpMemDel _ -> True
XGrpLeave -> True
XGrpDel -> True
XGrpInfo _ -> True
XGrpDirectInv {} -> True
_ -> False
processEvent :: MsgEncodingI e => CommandId -> ChatMessage e -> m Bool
processEvent :: MsgEncodingI e => CommandId -> ChatMessage e -> m ()
processEvent cmdId chatMsg = do
(m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg
updateChatLock "groupMessage" event
case event of
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs
@ -3672,15 +3760,17 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show event)
checkSendRcpt event
checkSendRcpt :: ChatMsgEvent e -> m Bool
checkSendRcpt event = do
checkSendRcpt :: [AChatMessage] -> m Bool
checkSendRcpt aChatMsgs = do
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
let GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo
pure $
fromMaybe (sendRcptsSmallGroups user) sendRcpts
&& hasDeliveryReceipt (toCMEventTag event)
&& any aChatMsgHasReceipt aChatMsgs
&& currentMemCount <= smallGroupsRcptsMemLimit
where
aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) =
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
forwardMsg_ :: MsgEncodingI e => ChatMessage e -> m ()
forwardMsg_ chatMsg =
forM_ (forwardedGroupMsg chatMsg) $ \chatMsg' -> do
@ -4017,15 +4107,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ackMsgDeliveryEvent :: Connection -> CommandId -> m ()
ackMsgDeliveryEvent Connection {connId} ackCmdId =
withStoreCtx'
(Just $ "createRcvMsgDeliveryEvent, connId: " <> show connId <> ", ackCmdId: " <> show ackCmdId <> ", msgDeliveryStatus: MDSRcvAcknowledged")
$ \db -> createRcvMsgDeliveryEvent db connId ackCmdId MDSRcvAcknowledged
withStore' $ \db -> updateRcvMsgDeliveryStatus db connId ackCmdId MDSRcvAcknowledged
sentMsgDeliveryEvent :: Connection -> AgentMsgId -> m ()
sentMsgDeliveryEvent Connection {connId} msgId =
withStoreCtx
(Just $ "createSndMsgDeliveryEvent, connId: " <> show connId <> ", msgId: " <> show msgId <> ", msgDeliveryStatus: MDSSndSent")
$ \db -> createSndMsgDeliveryEvent db connId msgId MDSSndSent
withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent
agentErrToItemStatus :: AgentErrorType -> CIStatus 'MDSnd
agentErrToItemStatus (SMP AUTH) = CISSndErrorAuth
@ -4287,14 +4373,15 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId
e -> throwError e
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> m ()
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> m ()
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
| otherwise = do
-- TODO integrity message check
-- check if message moderation event was received ahead of message
let timed_ = rcvGroupCITimed gInfo itemTTL
let timed_ =
if forwarded
then rcvCITimed_ (Just Nothing) itemTTL
else rcvGroupCITimed gInfo itemTTL
live = fromMaybe False live_
withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case
Just ciModeration -> do
@ -5221,7 +5308,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let body = LB.toStrict $ J.encode msg
rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
case event of
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
@ -5240,14 +5327,19 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
withStore $ \db -> createSndMsgDeliveryEvent db connId agentMsgId $ MDSSndRcvd msgRcptStatus
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
updateDirectItemStatus ct conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
-- TODO [batch send] update status of all messages in batch
-- - this is for when we implement identifying inactive connections
-- - regular messages sent in batch would all be marked as delivered by a single receipt
-- - repeat for directMsgReceived if same logic is applied to direct messages
-- - getChatItemIdByAgentMsgId to return [ChatItemId]
groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m ()
groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
withStore $ \db -> createSndMsgDeliveryEvent db connId agentMsgId $ MDSSndRcvd msgRcptStatus
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
updateGroupItemStatus gInfo m conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
updateDirectItemStatus :: Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> m ()
@ -5338,17 +5430,13 @@ sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg =
chSize = fromIntegral chunkSize
parseChatMessage :: ChatMonad m => Connection -> ByteString -> m (ChatMessage 'Json)
parseChatMessage conn = parseChatMessage_ conn Nothing
{-# INLINE parseChatMessage #-}
parseAChatMessage :: ChatMonad m => Connection -> MsgMeta -> ByteString -> m AChatMessage
parseAChatMessage conn msgMeta = parseChatMessage_ conn (Just msgMeta)
{-# INLINE parseAChatMessage #-}
parseChatMessage_ :: (ChatMonad m, StrEncoding s) => Connection -> Maybe MsgMeta -> ByteString -> m s
parseChatMessage_ conn msgMeta s = liftEither . first (ChatError . errType) $ strDecode s
parseChatMessage conn s = do
case parseChatMessages s of
[msg] -> liftEither . first (ChatError . errType) $ (\(ACMsg _ m) -> checkEncoding m) =<< msg
_ -> throwChatError $ CEException "parseChatMessage: single message is expected"
where
errType = CEInvalidChatMessage conn (msgMetaToJson <$> msgMeta) (safeDecodeUtf8 s)
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
{-# INLINE parseChatMessage #-}
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} =
@ -5525,40 +5613,77 @@ createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGro
createSndMessage chatMsgEvent connOrGroupId = do
gVar <- asks random
ChatConfig {chatVRange} <- asks config
withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
in NewMessage {chatMsgEvent, msgBody}
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage chatVRange)
where
encodeMessage chatVRange sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
sendGroupMemberMessages :: forall e m. (MsgEncodingI e, ChatMonad m) => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> m ()
sendGroupMemberMessages user conn@Connection {connId} events groupId = do
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
(errs, msgs) <- partitionEithers <$> createSndMessages
unless (null errs) $ toView $ CRChatErrors (Just user) errs
unless (null msgs) $ do
let (errs', msgBatches) = partitionEithers $ batchMessages maxChatMsgSize msgs
-- shouldn't happen, as large messages would have caused createNewSndMessage to throw SELargeMsg
unless (null errs') $ toView $ CRChatErrors (Just user) errs'
forM_ msgBatches $ \batch ->
processBatch batch `catchChatError` (toView . CRChatError (Just user))
where
processBatch :: MsgBatch -> m ()
processBatch (MsgBatch builder sndMsgs) = do
let batchBody = LB.toStrict $ toLazyByteString builder
agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) MsgFlags {notification = True} batchBody
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs
createSndMessages :: m [Either ChatError SndMessage]
createSndMessages = do
gVar <- asks random
ChatConfig {chatVRange} <- asks config
withStoreBatch $ \db -> map (createMsg db gVar chatVRange) (toList events)
createMsg db gVar chatVRange evnt = do
r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt)
pure $ first ChatErrorStore r
encodeMessage chatVRange evnt sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = evnt}
directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do
ChatConfig {chatVRange} <- asks config
pure $ strEncode ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
case r of
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
ECMLarge -> throwChatError $ CEException "large message"
deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64
deliverMessage conn cmEventTag msgBody msgId =
deliverMessages [(conn, cmEventTag, msgBody, msgId)] >>= \case
deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> LazyMsgBody -> MessageId -> m Int64
deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
deliverMessage' conn msgFlags msgBody msgId
deliverMessage' :: ChatMonad m => Connection -> MsgFlags -> LazyMsgBody -> MessageId -> m Int64
deliverMessage' conn msgFlags msgBody msgId =
deliverMessages [(conn, msgFlags, msgBody, msgId)] >>= \case
[r] -> liftEither r
rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs)
deliverMessages :: ChatMonad' m => [(Connection, CMEventTag e, MsgBody, MessageId)] -> m [Either ChatError Int64]
deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, LazyMsgBody, MessageId)] -> m [Either ChatError Int64]
deliverMessages msgReqs = do
sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs)
withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent
where
aReqs = map (\(conn, cmEvTag, msgBody, _msgId) -> (aConnId conn, msgFlags cmEvTag, msgBody)) msgReqs
msgFlags cmEvTag = MsgFlags {notification = hasNotification cmEvTag}
aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, LB.toStrict msgBody)) msgReqs
prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,)
createDelivery :: DB.Connection -> ((Connection, CMEventTag e, MsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64)
createDelivery :: DB.Connection -> ((Connection, MsgFlags, LazyMsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64)
createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) =
Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId
sendGroupMessage :: (MsgEncodingI e, ChatMonad m) => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> m (SndMessage, [GroupMember])
sendGroupMessage user GroupInfo {groupId} members chatMsgEvent = do
msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId)
recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) $ \GroupMember {memberRole} -> memberRole
let tag = toCMEventTag chatMsgEvent
recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members)
let msgFlags = MsgFlags {notification = hasNotification $ toCMEventTag chatMsgEvent}
(toSend, pending) = foldr addMember ([], []) recipientMembers
msgReqs = map (\(_, conn) -> (conn, tag, msgBody, msgId)) toSend
msgReqs = map (\(_, conn) -> (conn, msgFlags, msgBody, msgId)) toSend
delivered <- deliverMessages msgReqs
let errors = lefts delivered
unless (null errors) $ toView $ CRChatErrors (Just user) errors
@ -5566,6 +5691,12 @@ sendGroupMessage user GroupInfo {groupId} members chatMsgEvent = do
let sentToMembers = filterSent delivered toSend fst <> filterSent stored pending id
pure (msg, sentToMembers)
where
shuffleMembers :: [GroupMember] -> IO [GroupMember]
shuffleMembers ms = do
let (adminMs, otherMs) = partition isAdmin ms
liftM2 (<>) (shuffle adminMs) (shuffle otherMs)
where
isAdmin GroupMember {memberRole} = memberRole >= GRAdmin
addMember m (toSend, pending) = case memberSendAction chatMsgEvent members m of
Just (MSASend conn) -> ((m, conn) : toSend, pending)
Just MSAPending -> (toSend, m : pending)
@ -5614,15 +5745,6 @@ sendGroupMemberMessage user m@GroupMember {groupMemberId} chatMsgEvent groupId i
MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver
MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
shuffleMembers :: [a] -> (a -> GroupMemberRole) -> IO [a]
shuffleMembers ms role = do
let (adminMs, otherMs) = partition ((GRAdmin <=) . role) ms
liftM2 (<>) (shuffle adminMs) (shuffle otherMs)
where
random :: IO Word16
random = randomRIO (0, 65535)
shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) xs
sendPendingGroupMessages :: ChatMonad m => User -> GroupMember -> Connection -> m ()
sendPendingGroupMessages user GroupMember {groupMemberId, localDisplayName} conn = do
pendingMessages <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
@ -5639,21 +5761,25 @@ sendPendingGroupMessages user GroupMember {groupMemberId, localDisplayName} conn
_ -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName
_ -> pure ()
-- TODO [batch send] refactor direct message processing same as groups (e.g. checkIntegrity before processing)
saveDirectRcvMSG :: ChatMonad m => Connection -> MsgMeta -> CommandId -> MsgBody -> m (Connection, RcvMessage)
saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody = do
ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} <- parseAChatMessage conn agentMsgMeta msgBody
conn' <- updatePeerChatVRange conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewMessage {chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody =
case parseChatMessages msgBody of
[Right (ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent})] -> do
conn' <- updatePeerChatVRange conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
[Left e] -> error $ "saveDirectRcvMSG: error parsing chat message: " <> e
_ -> error "saveDirectRcvMSG: batching not supported"
saveGroupRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> CommandId -> MsgBody -> ChatMessage e -> m (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do
(am', conn') <- updateMemberChatVRange authorMember conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewMessage {chatMsgEvent, msgBody}
newMsg = NewRcvMessage {chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
amId = Just am'.groupMemberId
msg <-
@ -5669,7 +5795,7 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage
saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do
let newMsg = NewMessage {chatMsgEvent, msgBody}
let newMsg = NewRcvMessage {chatMsgEvent, msgBody}
fwdMemberId = Just $ groupMemberId' forwardingMember
refAuthorId = Just $ groupMemberId' refAuthorMember
withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId)
@ -6233,6 +6359,7 @@ chatCommandP =
"/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)),
"/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP),
"/set files #" *> (SetGroupFeature (AGF SGFFiles) <$> displayName <*> (A.space *> strP)),
"/set history #" *> (SetGroupFeature (AGF SGFHistory) <$> displayName <*> (A.space *> strP)),
"/set calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)),
"/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP),
"/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)),
@ -6320,7 +6447,12 @@ chatCommandP =
jsonP = J.eitherDecodeStrict' <$?> A.takeByteString
groupProfile = do
(gName, fullName) <- profileNames
let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just DirectMessagesGroupPreference {enable = FEOn}}
let groupPreferences =
Just
(emptyGroupPrefs :: GroupPreferences)
{ directMessages = Just DirectMessagesGroupPreference {enable = FEOn},
history = Just HistoryGroupPreference {enable = FEOn}
}
pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences}
fullNameP = A.space *> textP <|> pure ""
textP = safeDecodeUtf8 <$> A.takeByteString
@ -6358,6 +6490,7 @@ chatCommandP =
<|> ("day" $> 86400)
<|> ("week" $> (7 * 86400))
<|> ("month" $> (30 * 86400))
<|> A.decimal
timedTTLOnOffP =
optional ("on" *> A.space) *> (Just <$> timedTTLP)
<|> ("off" $> Nothing)

3
src/Simplex/Chat/Help.hs
View file

@ -155,7 +155,8 @@ groupsHelpInfo =
"",
green "Group chat preferences:",
indent <> highlight "/set voice #<group> on/off " <> " - enable/disable voice messages",
-- indent <> highlight "/set files #<group> on/off " <> " - enable/disable files and media (other than voice)",
indent <> highlight "/set files #<group> on/off " <> " - enable/disable files and media (other than voice)",
indent <> highlight "/set history #<group> on/off " <> " - enable/disable sending recent history to new members",
indent <> highlight "/set delete #<group> on/off " <> " - enable/disable full message deletion",
indent <> highlight "/set direct #<group> on/off " <> " - enable/disable direct messages to other members",
indent <> highlight "/set disappear #<group> on <time> " <> " - enable disappearing messages with <time>:",

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

@ -22,6 +22,7 @@ import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace)
import Data.Int (Int64)
@ -370,6 +371,9 @@ data CIQuote (c :: ChatType) = CIQuote
}
deriving (Show)
quoteItemId :: CIQuote c -> Maybe ChatItemId
quoteItemId CIQuote {itemId} = itemId
data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction
{ chatDir :: CIDirection c d,
chatItem :: CChatItem c,
@ -760,17 +764,20 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
Just Refl -> Right x
Nothing -> Left "bad chat type"
data NewMessage e = NewMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody
}
deriving (Show)
type LazyMsgBody = L.ByteString
data SndMessage = SndMessage
{ msgId :: MessageId,
sharedMsgId :: SharedMsgId,
msgBody :: LazyMsgBody
}
deriving (Show)
data NewRcvMessage e = NewRcvMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody
}
deriving (Show)
data RcvMessage = RcvMessage
{ msgId :: MessageId,
@ -784,7 +791,7 @@ data RcvMessage = RcvMessage
data PendingGroupMessage = PendingGroupMessage
{ msgId :: MessageId,
cmEventTag :: ACMEventTag,
msgBody :: MsgBody,
msgBody :: LazyMsgBody,
introId_ :: Maybe Int64
}

53
src/Simplex/Chat/Messages/Batch.hs Normal file
View file

@ -0,0 +1,53 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Messages.Batch
( MsgBatch (..),
batchMessages,
)
where
import Data.ByteString.Builder (Builder, charUtf8, lazyByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Int (Int64)
import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
import Simplex.Chat.Messages
data MsgBatch = MsgBatch Builder [SndMessage]
deriving (Show)
-- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays.
-- Does not check if the resulting batch is a valid JSON.
-- If a single element is passed, it is returned as is (a JSON string).
-- If an element exceeds maxLen, it is returned as ChatError.
batchMessages :: Int64 -> [SndMessage] -> [Either ChatError MsgBatch]
batchMessages maxLen msgs =
let (batches, batch, _, n) = foldr addToBatch ([], [], 0, 0) msgs
in if n == 0 then batches else msgBatch batch : batches
where
msgBatch batch = Right (MsgBatch (encodeMessages batch) batch)
addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int)
addToBatch msg@SndMessage {msgBody} (batches, batch, len, n)
| batchLen <= maxLen = (batches, msg : batch, len', n + 1)
| msgLen <= maxLen = (batches', [msg], msgLen, 1)
| otherwise = (errLarge msg : (if n == 0 then batches else batches'), [], 0, 0)
where
msgLen = LB.length msgBody
batches' = msgBatch batch : batches
len'
| n == 0 = msgLen
| otherwise = msgLen + len + 1 -- 1 accounts for comma
batchLen
| n == 0 = len'
| otherwise = len' + 2 -- 2 accounts for opening and closing brackets
errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId)
encodeMessages :: [SndMessage] -> Builder
encodeMessages = \case
[] -> mempty
[msg] -> encodeMsg msg
(msg : msgs) -> charUtf8 '[' <> encodeMsg msg <> mconcat [charUtf8 ',' <> encodeMsg msg' | msg' <- msgs] <> charUtf8 ']'
where
encodeMsg SndMessage {msgBody} = lazyByteString msgBody

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

@ -575,10 +575,16 @@ dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8
instance FromJSON ACIContent where
parseJSON = fmap aciContentJSON . J.parseJSON
sndMsgContentTag :: Text
sndMsgContentTag = "sndMsgContent"
rcvMsgContentTag :: Text
rcvMsgContentTag = "rcvMsgContent"
toCIContentTag :: CIContent e -> Text
toCIContentTag ciContent = case ciContent of
CISndMsgContent _ -> "sndMsgContent"
CIRcvMsgContent _ -> "rcvMsgContent"
CISndMsgContent _ -> sndMsgContentTag
CIRcvMsgContent _ -> rcvMsgContentTag
CISndDeleted _ -> "sndDeleted"
CIRcvDeleted _ -> "rcvDeleted"
CISndCall {} -> "sndCall"

100
src/Simplex/Chat/Migrations/M20231215_recreate_msg_deliveries.hs Normal file
View file

@ -0,0 +1,100 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231215_recreate_msg_deliveries :: Query
m20231215_recreate_msg_deliveries =
[sql|
DROP INDEX msg_delivery_events_msg_delivery_id;
DROP TABLE msg_delivery_events;
DROP INDEX idx_msg_deliveries_message_id;
DROP INDEX idx_msg_deliveries_agent_ack_cmd_id;
CREATE TABLE new_msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages and for batched messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID (NULL while pending), non UNIQUE for batched messages
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
delivery_status TEXT -- MsgDeliveryStatus
);
INSERT INTO new_msg_deliveries (
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
)
SELECT
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
FROM msg_deliveries;
DROP TABLE msg_deliveries;
ALTER TABLE new_msg_deliveries RENAME TO msg_deliveries;
CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(connection_id, agent_ack_cmd_id);
CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"(connection_id, agent_msg_id);
|]
down_m20231215_recreate_msg_deliveries :: Query
down_m20231215_recreate_msg_deliveries =
[sql|
DROP INDEX idx_msg_deliveries_message_id;
DROP INDEX idx_msg_deliveries_agent_ack_cmd_id;
DROP INDEX idx_msg_deliveries_agent_msg_id;
CREATE TABLE old_msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID(NULL while pending)
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
UNIQUE(connection_id, agent_msg_id)
);
INSERT INTO old_msg_deliveries (
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
)
WITH unique_msg_deliveries AS (
SELECT
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id,
row_number() OVER connection_id_agent_msg_id_win AS row_number
FROM msg_deliveries
WINDOW connection_id_agent_msg_id_win AS (PARTITION BY connection_id, agent_msg_id ORDER BY created_at ASC, msg_delivery_id ASC)
)
SELECT
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
FROM unique_msg_deliveries
WHERE row_number = 1;
DROP TABLE msg_deliveries;
ALTER TABLE old_msg_deliveries RENAME TO msg_deliveries;
CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(connection_id, agent_ack_cmd_id);
CREATE TABLE msg_delivery_events (
msg_delivery_event_id INTEGER PRIMARY KEY,
msg_delivery_id INTEGER NOT NULL REFERENCES msg_deliveries ON DELETE CASCADE, -- non UNIQUE for multiple events per msg delivery
delivery_status TEXT NOT NULL, -- see MsgDeliveryStatus for allowed values
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')),
UNIQUE (msg_delivery_id, delivery_status)
);
CREATE INDEX msg_delivery_events_msg_delivery_id ON msg_delivery_events(msg_delivery_id);
|]

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

@ -330,18 +330,6 @@ CREATE TABLE messages(
author_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL
);
CREATE TABLE msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID(NULL while pending)
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
UNIQUE(connection_id, agent_msg_id)
);
CREATE TABLE pending_group_messages(
pending_group_message_id INTEGER PRIMARY KEY,
group_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
@ -450,13 +438,6 @@ CREATE TABLE extra_xftp_file_descriptions(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE msg_delivery_events(
msg_delivery_event_id INTEGER PRIMARY KEY,
msg_delivery_id INTEGER NOT NULL REFERENCES msg_deliveries ON DELETE CASCADE,
delivery_status TEXT NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE chat_item_versions(
-- contains versions only for edited chat items, including current version
chat_item_version_id INTEGER PRIMARY KEY AUTOINCREMENT,
@ -554,6 +535,18 @@ CREATE TABLE remote_controllers(
dh_priv_key BLOB NOT NULL, -- last session DH key
prev_dh_priv_key BLOB -- previous session DH key
);
CREATE TABLE IF NOT EXISTS "msg_deliveries"(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages and for batched messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID(NULL while pending), non UNIQUE for batched messages
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
delivery_status TEXT -- MsgDeliveryStatus
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@ -585,7 +578,6 @@ CREATE UNIQUE INDEX idx_chat_items_group_shared_msg_id ON chat_items(
group_member_id,
shared_msg_id
);
CREATE INDEX idx_msg_deliveries_message_id ON msg_deliveries(message_id);
CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links(
group_id
);
@ -717,13 +709,6 @@ CREATE INDEX idx_chat_items_timed_delete_at ON chat_items(
timed_delete_at
);
CREATE INDEX idx_group_members_group_id ON group_members(user_id, group_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON msg_deliveries(
connection_id,
agent_ack_cmd_id
);
CREATE INDEX msg_delivery_events_msg_delivery_id ON msg_delivery_events(
msg_delivery_id
);
CREATE INDEX idx_chat_item_moderations_group_id ON chat_item_moderations(
group_id
);
@ -818,3 +803,12 @@ CREATE INDEX idx_contact_requests_updated_at ON contact_requests(
updated_at
);
CREATE INDEX idx_connections_updated_at ON connections(user_id, updated_at);
CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(
connection_id,
agent_ack_cmd_id
);
CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"(
connection_id,
agent_msg_id
);

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

@ -29,7 +29,9 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
@ -51,7 +53,7 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
currentChatVersion :: Version
currentChatVersion = 4
currentChatVersion = 5
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion
@ -72,6 +74,10 @@ groupLinkNoContactVRange = mkVersionRange 3 currentChatVersion
groupForwardVRange :: VersionRange
groupForwardVRange = mkVersionRange 4 currentChatVersion
-- version range that supports batch sending in groups
batchSendVRange :: VersionRange
batchSendVRange = mkVersionRange 5 currentChatVersion
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@ -447,6 +453,18 @@ durationText duration =
| n <= 9 = '0' : show n
| otherwise = show n
msgContentHasText :: MsgContent -> Bool
msgContentHasText = \case
MCText t -> hasText t
MCLink {text} -> hasText text
MCImage {text} -> hasText text
MCVideo {text} -> hasText text
MCVoice {text} -> hasText text
MCFile t -> hasText t
MCUnknown {text} -> hasText text
where
hasText = not . T.null
isVoice :: MsgContent -> Bool
isVoice = \case
MCVoice {} -> True
@ -467,18 +485,34 @@ data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInv
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
instance MsgEncodingI e => StrEncoding (ChatMessage e) where
strEncode msg = case chatToAppMessage msg of
AMJson m -> LB.toStrict $ J.encode m
AMBinary m -> strEncode m
strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
-- this limit reserves space for metadata in forwarded messages
-- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, round to 15610
maxChatMsgSize :: Int64
maxChatMsgSize = 15610
instance StrEncoding AChatMessage where
strEncode (ACMsg _ m) = strEncode m
strP =
A.peekChar' >>= \case
'{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
_ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
data EncodedChatMessage = ECMEncoded L.ByteString | ECMLarge
encodeChatMessage :: MsgEncodingI e => ChatMessage e -> EncodedChatMessage
encodeChatMessage msg = do
case chatToAppMessage msg of
AMJson m -> do
let body = J.encode m
if LB.length body > maxChatMsgSize
then ECMLarge
else ECMEncoded body
AMBinary m -> ECMEncoded . LB.fromStrict $ strEncode m
parseChatMessages :: ByteString -> [Either String AChatMessage]
parseChatMessages "" = [Left "empty string"]
parseChatMessages s = case B.head s of
'{' -> [ACMsg SJson <$> J.eitherDecodeStrict' s]
'[' -> case J.eitherDecodeStrict' s of
Right v -> map parseItem v
Left e -> [Left e]
_ -> [ACMsg SBinary <$> (appBinaryToCM =<< strDecode s)]
where
parseItem :: J.Value -> Either String AChatMessage
parseItem v = ACMsg SJson <$> JT.parseEither parseJSON v
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
parseMsgContainer v =

45
src/Simplex/Chat/Store/Files.hs
View file

@ -47,7 +47,8 @@ module Simplex.Chat.Store.Files
createRcvFileTransfer,
createRcvGroupFileTransfer,
appendRcvFD,
getRcvFileDescrByFileId,
getRcvFileDescrByRcvFileId,
getRcvFileDescrBySndFileId,
updateRcvFileAgentId,
getRcvFileTransferById,
getRcvFileTransfer,
@ -543,7 +544,7 @@ createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, file
appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr
appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
currentTs <- liftIO getCurrentTime
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
Nothing -> do
rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd
liftIO $
@ -572,14 +573,14 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD
(fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId)
pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete}
getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByFileId db fileId = do
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
getRcvFileDescrByRcvFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByRcvFileId db fileId = do
liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrByFileId_ db fileId =
getRcvFileDescrByRcvFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrByRcvFileId_ db fileId =
maybeFirstRow toRcvFileDescr $
DB.query
db
@ -591,10 +592,30 @@ getRcvFileDescrByFileId_ db fileId =
LIMIT 1
|]
(Only fileId)
where
toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr
toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) =
RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
getRcvFileDescrBySndFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrBySndFileId db fileId = do
liftIO (getRcvFileDescrBySndFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
getRcvFileDescrBySndFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrBySndFileId_ db fileId =
maybeFirstRow toRcvFileDescr $
DB.query
db
[sql|
SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete
FROM xftp_file_descriptions d
JOIN snd_files f ON f.file_descr_id = d.file_descr_id
WHERE f.file_id = ?
LIMIT 1
|]
(Only fileId)
toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr
toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) =
RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO ()
updateRcvFileAgentId db fileId aFileId = do
@ -627,7 +648,7 @@ getRcvFileTransfer_ db userId fileId = do
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId
rfd_ <- liftIO $ getRcvFileDescrByRcvFileId_ db fileId
rcvFileTransfer rfd_ rftRow
where
rcvFileTransfer ::

2
src/Simplex/Chat/Store/Groups.hs
View file

@ -150,7 +150,7 @@ type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Ver
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = toGroupMember userContactId userMemberRow
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange supportedChatVRange}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}

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

@ -24,8 +24,8 @@ module Simplex.Chat.Store.Messages
createSndMsgDelivery,
createNewMessageAndRcvMsgDelivery,
createNewRcvMessage,
createSndMsgDeliveryEvent,
createRcvMsgDeliveryEvent,
updateSndMsgDeliveryStatus,
updateRcvMsgDeliveryStatus,
createPendingGroupMessage,
getPendingGroupMessages,
deletePendingGroupMessage,
@ -99,6 +99,7 @@ module Simplex.Chat.Store.Messages
updateGroupSndStatus,
getGroupSndStatuses,
getGroupSndStatusCounts,
getGroupHistoryItems,
)
where
@ -159,49 +160,59 @@ deleteGroupCIs db User {userId} GroupInfo {groupId} = do
DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId)
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId)
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId mkMessage =
createWithRandomId gVar $ \sharedMsgId -> do
let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?)
|]
(MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
msgId <- insertedRowId db
pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId chatMsgEvent encodeMessage =
createWithRandomId' gVar $ \sharedMsgId ->
case encodeMessage (SharedMsgId sharedMsgId) of
ECMLarge -> pure $ Left SELargeMsg
ECMEncoded msgBody -> do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?)
|]
(MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
msgId <- insertedRowId db
pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId -> (Just connId, Nothing)
GroupId groupId -> (Nothing, Just groupId)
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery db sndMsgDelivery messageId = do
createSndMsgDelivery db SndMsgDelivery {connId, agentMsgId} messageId = do
currentTs <- getCurrentTime
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
pure msgDeliveryId
DB.execute
db
[sql|
INSERT INTO msg_deliveries
(message_id, connection_id, agent_msg_id, chat_ts, created_at, updated_at, delivery_status)
VALUES (?,?,?,?,?,?,?)
|]
(messageId, connId, agentMsgId, currentTs, currentTs, currentTs, MDSSndAgent)
insertedRowId db
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} authorGroupMemberId_ = do
msg@RcvMessage {msgId} <- createNewRcvMessage db connOrGroupId newMessage sharedMsgId_ authorGroupMemberId_ Nothing
liftIO $ do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs)
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
[sql|
INSERT INTO msg_deliveries
(message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at, delivery_status)
VALUES (?,?,?,?,?,?,?,?,?)
|]
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs, MDSRcvAgent)
pure msg
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of
@ -236,68 +247,29 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs
msgId <- insertedRowId db
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
msgDeliveryId <- getMsgDeliveryId_ db connId agentMsgId
liftIO $ do
currentTs <- getCurrentTime
createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs
createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO ()
createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do
msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId
forM_ msgDeliveryId $ \mdId -> do
currentTs <- getCurrentTime
createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do
updateSndMsgDeliveryStatus :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> IO ()
updateSndMsgDeliveryStatus db connId agentMsgId sndMsgDeliveryStatus = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO msg_deliveries
(message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at)
VALUES (?,?,?,NULL,?,?,?)
UPDATE msg_deliveries
SET delivery_status = ?, updated_at = ?
WHERE connection_id = ? AND agent_msg_id = ?
|]
(messageId, connId, agentMsgId, createdAt, createdAt, createdAt)
insertedRowId db
(sndMsgDeliveryStatus, currentTs, connId, agentMsgId)
createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO ()
createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do
updateRcvMsgDeliveryStatus :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO ()
updateRcvMsgDeliveryStatus db connId cmdId rcvMsgDeliveryStatus = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO msg_delivery_events
(msg_delivery_id, delivery_status, created_at, updated_at)
VALUES (?,?,?,?)
UPDATE msg_deliveries
SET delivery_status = ?, updated_at = ?
WHERE connection_id = ? AND agent_ack_cmd_id = ?
|]
(msgDeliveryId, msgDeliveryStatus, createdAt, createdAt)
getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64
getMsgDeliveryId_ db connId agentMsgId =
ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $
DB.query
db
[sql|
SELECT msg_delivery_id
FROM msg_deliveries m
WHERE m.connection_id = ? AND m.agent_msg_id = ?
LIMIT 1
|]
(connId, agentMsgId)
getMsgDeliveryIdByCmdId_ :: DB.Connection -> Int64 -> CommandId -> IO (Maybe AgentMsgId)
getMsgDeliveryIdByCmdId_ db connId cmdId =
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT msg_delivery_id
FROM msg_deliveries
WHERE connection_id = ? AND agent_ack_cmd_id = ?
LIMIT 1
|]
(connId, cmdId)
(rcvMsgDeliveryStatus, currentTs, connId, cmdId)
createPendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> Maybe Int64 -> IO ()
createPendingGroupMessage db groupMemberId messageId introId_ = do
@ -2107,3 +2079,25 @@ getGroupSndStatusCounts db itemId =
GROUP BY group_snd_item_status
|]
(Only itemId)
getGroupHistoryItems :: DB.Connection -> User -> GroupInfo -> Int -> IO [Either StoreError (CChatItem 'CTGroup)]
getGroupHistoryItems db user@User {userId} GroupInfo {groupId} count = do
chatItemIds <- getLastItemIds_
-- use getGroupCIWithReactions to read reactions data
reverse <$> mapM (runExceptT . getGroupChatItem db user groupId) chatItemIds
where
getLastItemIds_ :: IO [ChatItemId]
getLastItemIds_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ?
AND item_content_tag IN (?,?)
AND item_deleted = 0
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, rcvMsgContentTag, sndMsgContentTag, count)

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

@ -93,6 +93,7 @@ import Simplex.Chat.Migrations.M20231114_remote_control
import Simplex.Chat.Migrations.M20231126_remote_ctrl_address
import Simplex.Chat.Migrations.M20231207_chat_list_pagination
import Simplex.Chat.Migrations.M20231214_item_content_tag
import Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -185,7 +186,8 @@ schemaMigrations =
("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control),
("20231126_remote_ctrl_address", m20231126_remote_ctrl_address, Just down_m20231126_remote_ctrl_address),
("20231207_chat_list_pagination", m20231207_chat_list_pagination, Just down_m20231207_chat_list_pagination),
("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag)
("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag),
("20231215_recreate_msg_deliveries", m20231215_recreate_msg_deliveries, Just down_m20231215_recreate_msg_deliveries)
]
-- | The list of migrations in ascending order by date

14
src/Simplex/Chat/Store/Shared.hs
View file

@ -32,7 +32,7 @@ import Simplex.Chat.Protocol
import Simplex.Chat.Remote.Types
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
@ -86,8 +86,8 @@ data StoreError
| SEPendingConnectionNotFound {connId :: Int64}
| SEIntroNotFound
| SEUniqueID
| SELargeMsg
| SEInternalError {message :: String}
| SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId}
| SEBadChatItem {itemId :: ChatItemId}
| SEChatItemNotFound {itemId :: ChatItemId}
| SEChatItemNotFoundByText {text :: Text}
@ -376,15 +376,21 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate
createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomId = createWithRandomBytes 12
createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomId' = createWithRandomBytes' 12
createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomBytes size gVar create = tryCreate 3
createWithRandomBytes size gVar create = createWithRandomBytes' size gVar (fmap Right . create)
createWithRandomBytes' :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomBytes' size gVar create = tryCreate 3
where
tryCreate :: Int -> ExceptT StoreError IO a
tryCreate 0 = throwError SEUniqueID
tryCreate n = do
id' <- liftIO $ encodedRandomBytes gVar size
liftIO (E.try $ create id') >>= \case
Right x -> pure x
Right x -> liftEither x
Left e
| SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1)
| otherwise -> throwError . SEInternalError $ show e

7
src/Simplex/Chat/Types.hs
View file

@ -627,7 +627,8 @@ data GroupMember = GroupMember
memberContactProfileId :: ProfileId,
activeConn :: Maybe Connection,
-- member chat protocol version range; if member has active connection, its version range is preferred;
-- for membership current supportedChatVRange is set, it's not updated on protocol version increase
-- for membership current supportedChatVRange is set, it's not updated on protocol version increase in database,
-- but it's correctly set on read (see toGroupInfo)
memberChatVRange :: JVersionRange
}
deriving (Eq, Show)
@ -1012,9 +1013,11 @@ data XFTPRcvFile = XFTPRcvFile
}
deriving (Eq, Show)
type RcvFileDescrText = Text
data RcvFileDescr = RcvFileDescr
{ fileDescrId :: Int64,
fileDescrText :: Text,
fileDescrText :: RcvFileDescrText,
fileDescrPartNo :: Int,
fileDescrComplete :: Bool
}

41
src/Simplex/Chat/Types/Preferences.hs
View file

@ -149,6 +149,7 @@ data GroupFeature
| GFReactions
| GFVoice
| GFFiles
| GFHistory
deriving (Show)
data SGroupFeature (f :: GroupFeature) where
@ -158,6 +159,7 @@ data SGroupFeature (f :: GroupFeature) where
SGFReactions :: SGroupFeature 'GFReactions
SGFVoice :: SGroupFeature 'GFVoice
SGFFiles :: SGroupFeature 'GFFiles
SGFHistory :: SGroupFeature 'GFHistory
deriving instance Show (SGroupFeature f)
@ -173,6 +175,7 @@ groupFeatureNameText = \case
GFReactions -> "Message reactions"
GFVoice -> "Voice messages"
GFFiles -> "Files and media"
GFHistory -> "Recent history"
groupFeatureNameText' :: SGroupFeature f -> Text
groupFeatureNameText' = groupFeatureNameText . toGroupFeature
@ -188,7 +191,8 @@ allGroupFeatures =
AGF SGFFullDelete,
AGF SGFReactions,
AGF SGFVoice,
AGF SGFFiles
AGF SGFFiles,
AGF SGFHistory
]
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
@ -199,6 +203,7 @@ groupPrefSel f ps = case f of
SGFReactions -> ps.reactions
SGFVoice -> ps.voice
SGFFiles -> ps.files
SGFHistory -> ps.history
toGroupFeature :: SGroupFeature f -> GroupFeature
toGroupFeature = \case
@ -208,6 +213,7 @@ toGroupFeature = \case
SGFReactions -> GFReactions
SGFVoice -> GFVoice
SGFFiles -> GFFiles
SGFHistory -> GFHistory
class GroupPreferenceI p where
getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f
@ -226,6 +232,7 @@ instance GroupPreferenceI FullGroupPreferences where
SGFReactions -> ps.reactions
SGFVoice -> ps.voice
SGFFiles -> ps.files
SGFHistory -> ps.history
{-# INLINE getGroupPreference #-}
-- collection of optional group preferences
@ -235,7 +242,8 @@ data GroupPreferences = GroupPreferences
fullDelete :: Maybe FullDeleteGroupPreference,
reactions :: Maybe ReactionsGroupPreference,
voice :: Maybe VoiceGroupPreference,
files :: Maybe FilesGroupPreference
files :: Maybe FilesGroupPreference,
history :: Maybe HistoryGroupPreference
}
deriving (Eq, Show)
@ -260,6 +268,7 @@ setGroupPreference_ f pref prefs =
SGFReactions -> prefs {reactions = pref}
SGFVoice -> prefs {voice = pref}
SGFFiles -> prefs {files = pref}
SGFHistory -> prefs {history = pref}
setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences
setGroupTimedMessagesPreference pref prefs_ =
@ -286,7 +295,8 @@ data FullGroupPreferences = FullGroupPreferences
fullDelete :: FullDeleteGroupPreference,
reactions :: ReactionsGroupPreference,
voice :: VoiceGroupPreference,
files :: FilesGroupPreference
files :: FilesGroupPreference,
history :: HistoryGroupPreference
}
deriving (Eq, Show)
@ -341,11 +351,12 @@ defaultGroupPrefs =
fullDelete = FullDeleteGroupPreference {enable = FEOff},
reactions = ReactionsGroupPreference {enable = FEOn},
voice = VoiceGroupPreference {enable = FEOn},
files = FilesGroupPreference {enable = FEOn}
files = FilesGroupPreference {enable = FEOn},
history = HistoryGroupPreference {enable = FEOff}
}
emptyGroupPrefs :: GroupPreferences
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data TimedMessagesPreference = TimedMessagesPreference
{ allow :: FeatureAllowed,
@ -440,6 +451,10 @@ data FilesGroupPreference = FilesGroupPreference
{enable :: GroupFeatureEnabled}
deriving (Eq, Show)
data HistoryGroupPreference = HistoryGroupPreference
{enable :: GroupFeatureEnabled}
deriving (Eq, Show)
class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where
type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
sGroupFeature :: SGroupFeature f
@ -466,6 +481,9 @@ instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable)
instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable)
instance GroupFeatureI 'GFTimedMessages where
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
sGroupFeature = SGFTimedMessages
@ -496,6 +514,11 @@ instance GroupFeatureI 'GFFiles where
sGroupFeature = SGFFiles
groupPrefParam _ = Nothing
instance GroupFeatureI 'GFHistory where
type GroupFeaturePreference 'GFHistory = HistoryGroupPreference
sGroupFeature = SGFHistory
groupPrefParam _ = Nothing
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text
groupPrefStateText feature pref param =
let enabled = getField @"enable" pref
@ -618,7 +641,8 @@ mergeGroupPreferences groupPreferences =
fullDelete = pref SGFFullDelete,
reactions = pref SGFReactions,
voice = pref SGFVoice,
files = pref SGFFiles
files = pref SGFFiles,
history = pref SGFHistory
}
where
pref :: SGroupFeature f -> GroupFeaturePreference f
@ -632,7 +656,8 @@ toGroupPreferences groupPreferences =
fullDelete = pref SGFFullDelete,
reactions = pref SGFReactions,
voice = pref SGFVoice,
files = pref SGFFiles
files = pref SGFFiles,
history = pref SGFHistory
}
where
pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f)
@ -738,6 +763,8 @@ $(J.deriveJSON defaultJSON ''VoiceGroupPreference)
$(J.deriveJSON defaultJSON ''FilesGroupPreference)
$(J.deriveJSON defaultJSON ''HistoryGroupPreference)
$(J.deriveJSON defaultJSON ''GroupPreferences)
instance ToField GroupPreferences where

14
src/Simplex/Chat/Util.hs
View file

@ -1,12 +1,18 @@
module Simplex.Chat.Util (week, encryptFile, chunkSize) where
{-# LANGUAGE TupleSections #-}
module Simplex.Chat.Util (week, encryptFile, chunkSize, shuffle) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as LB
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Time (NominalDiffTime)
import Data.Word (Word16)
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import System.Random (randomRIO)
import UnliftIO.IO (IOMode (..), withFile)
week :: NominalDiffTime
@ -30,3 +36,9 @@ encryptFile fromPath toPath cfArgs = do
chunkSize :: Num a => a
chunkSize = 65536
{-# INLINE chunkSize #-}
shuffle :: [a] -> IO [a]
shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) xs
where
random :: IO Word16
random = randomRIO (0, 65535)

8
tests/ChatTests/Files.hs
View file

@ -16,14 +16,11 @@ import Simplex.Chat (roundedFDCount)
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig)
import Simplex.Chat.Mobile.File
import Simplex.Chat.Options (ChatOpts (..))
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (unlessM)
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getFileSize)
import System.Environment (withArgs)
import System.IO.Silently (capture_)
import Test.Hspec
chatFileTests :: SpecWith FilePath
@ -1496,7 +1493,7 @@ testXFTPCancelRcvRepeat =
dest <- B.readFile "./tests/tmp/testfile_1"
dest `shouldBe` src
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
cfg = testCfg {xftpDescrPartSize = 200, xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testAutoAcceptFile :: HasCallStack => FilePath -> IO ()
testAutoAcceptFile =
@ -1548,9 +1545,6 @@ testProhibitFiles =
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
xftpCLI :: [String] -> IO [String]
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
startFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
startFileTransfer alice bob =
startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"

746
tests/ChatTests/Groups.hs
View file

@ -115,6 +115,19 @@ chatGroupTests = do
it "forward file (x.msg.file.descr)" testGroupMsgForwardFile
it "forward role change (x.grp.mem.role)" testGroupMsgForwardChangeRole
it "forward new member announcement (x.grp.mem.new)" testGroupMsgForwardNewMember
describe "group history" $ do
it "text messages" testGroupHistory
it "history is sent when joining via group link" testGroupHistoryGroupLink
it "history is not sent if preference is disabled" testGroupHistoryPreferenceOff
it "host's file" testGroupHistoryHostFile
it "member's file" testGroupHistoryMemberFile
it "large file with text" testGroupHistoryLargeFile
it "multiple files" testGroupHistoryMultipleFiles
it "cancelled files are not attached (text message is still sent)" testGroupHistoryFileCancel
it "cancelled files without text are excluded" testGroupHistoryFileCancelNoText
it "quoted messages" testGroupHistoryQuotes
it "deleted message is not included" testGroupHistoryDeletedMessage
it "disappearing message is sent as disappearing" testGroupHistoryDisappearingMessage
where
_0 = supportedChatVRange -- don't create direct connections
_1 = groupCreateDirectVRange
@ -1447,6 +1460,7 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile
alice <## "Message reactions: on"
alice <## "Voice messages: on"
alice <## "Files and media: on"
alice <## "Recent history: on"
bobAddedDan :: HasCallStack => TestCC -> IO ()
bobAddedDan cc = do
cc <## "#team: bob added dan (Daniel) to the group (connecting...)"
@ -4116,3 +4130,735 @@ testGroupMsgForwardNewMember =
"cath (Catherine): admin, connected",
"dan (Daniel): member"
]
testGroupHistory :: HasCallStack => FilePath -> IO ()
testGroupHistory =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team hello"
bob <# "#team alice> hello"
threadDelay 1000000
bob #> "#team hey!"
alice <# "#team bob> hey!"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> hello [>>]",
WithTime "#team bob> hey! [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/_get chat #1 count=100"
r <- chat <$> getTermLine cath
r `shouldContain` [(0, "hello"), (0, "hey!")]
-- message delivery works after sending history
alice #> "#team 1"
[bob, cath] *<# "#team alice> 1"
bob #> "#team 2"
[alice, cath] *<# "#team bob> 2"
cath #> "#team 3"
[alice, bob] *<# "#team cath> 3"
testGroupHistoryGroupLink :: HasCallStack => FilePath -> IO ()
testGroupHistoryGroupLink =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team hello"
bob <# "#team alice> hello"
threadDelay 1000000
bob #> "#team hey!"
alice <# "#team bob> hey!"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
cath ##> ("/c " <> gLink)
cath <## "connection request sent!"
alice <## "cath (Catherine): accepting request to join group #team..."
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: joining the group...",
"#team: you joined the group",
WithTime "#team alice> hello [>>]",
WithTime "#team bob> hey! [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/_get chat #1 count=100"
r <- chat <$> getTermLine cath
r `shouldContain` [(0, "hello"), (0, "hey!")]
-- message delivery works after sending history
alice #> "#team 1"
[bob, cath] *<# "#team alice> 1"
bob #> "#team 2"
[alice, cath] *<# "#team bob> 2"
cath #> "#team 3"
[alice, bob] *<# "#team cath> 3"
testGroupHistoryPreferenceOff :: HasCallStack => FilePath -> IO ()
testGroupHistoryPreferenceOff =
testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team hello"
bob <# "#team alice> hello"
threadDelay 1000000
bob #> "#team hey!"
alice <# "#team bob> hey!"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> hello [>>]",
WithTime "#team bob> hey! [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/_get chat #1 count=100"
r <- chat <$> getTermLine cath
r `shouldContain` [(0, "hello"), (0, "hey!")]
alice ##> "/set history #team off"
alice <## "updated group preferences:"
alice <## "Recent history: off"
concurrentlyN_
[ do
bob <## "alice updated group #team:"
bob <## "updated group preferences:"
bob <## "Recent history: off",
do
cath <## "alice updated group #team:"
cath <## "updated group preferences:"
cath <## "Recent history: off"
]
connectUsers alice dan
addMember "team" alice dan GRAdmin
dan ##> "/j team"
concurrentlyN_
[ alice <## "#team: dan joined the group",
do
dan <## "#team: you joined the group"
dan
<### [ "#team: member bob (Bob) is connected",
"#team: member cath (Catherine) is connected"
],
aliceAddedDan bob,
aliceAddedDan cath
]
dan ##> "/_get chat #1 count=100"
r' <- chat <$> getTermLine dan
r' `shouldNotContain` [(0, "hello")]
r' `shouldNotContain` [(0, "hey!")]
where
aliceAddedDan :: HasCallStack => TestCC -> IO ()
aliceAddedDan cc = do
cc <## "#team: alice added dan (Daniel) to the group (connecting...)"
cc <## "#team: new member dan is connected"
testGroupHistoryHostFile :: HasCallStack => FilePath -> IO ()
testGroupHistoryHostFile =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
createGroup2 "team" alice bob
alice #> "/f #team ./tests/fixtures/test.jpg"
alice <## "use /fc 1 to cancel sending"
alice <## "completed uploading file 1 (test.jpg) for #team"
bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]",
"use /fr 1 [<dir>/ | <path>] to receive it [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath
<### [ "saving file 1 from alice to ./tests/tmp/test.jpg",
"started receiving file 1 (test.jpg) from alice"
]
cath <## "completed receiving file 1 (test.jpg) from alice"
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest `shouldBe` src
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupHistoryMemberFile :: HasCallStack => FilePath -> IO ()
testGroupHistoryMemberFile =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
createGroup2 "team" alice bob
bob #> "/f #team ./tests/fixtures/test.jpg"
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (test.jpg) for #team"
alice <# "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]",
"use /fr 1 [<dir>/ | <path>] to receive it [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath
<### [ "saving file 1 from bob to ./tests/tmp/test.jpg",
"started receiving file 1 (test.jpg) from bob"
]
cath <## "completed receiving file 1 (test.jpg) from bob"
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest `shouldBe` src
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupHistoryLargeFile :: HasCallStack => FilePath -> IO ()
testGroupHistoryLargeFile =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile"]
createGroup2 "team" alice bob
bob ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}"
bob <# "#team hello"
bob <# "/f #team ./tests/tmp/testfile"
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile) for #team"
alice <# "#team bob> hello"
alice <# "#team bob> sends file testfile (17.0 MiB / 17825792 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
-- admin receiving file does not prevent the new member from receiving it later
alice ##> "/fr 1 ./tests/tmp"
alice
<### [ "saving file 1 from bob to ./tests/tmp/testfile_1",
"started receiving file 1 (testfile) from bob"
]
alice <## "completed receiving file 1 (testfile) from bob"
src <- B.readFile "./tests/tmp/testfile"
destAlice <- B.readFile "./tests/tmp/testfile_1"
destAlice `shouldBe` src
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team bob> hello [>>]",
WithTime "#team bob> sends file testfile (17.0 MiB / 17825792 bytes) [>>]",
"use /fr 1 [<dir>/ | <path>] to receive it [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath
<### [ "saving file 1 from bob to ./tests/tmp/testfile_2",
"started receiving file 1 (testfile) from bob"
]
cath <## "completed receiving file 1 (testfile) from bob"
destCath <- B.readFile "./tests/tmp/testfile_2"
destCath `shouldBe` src
where
cfg = testCfg {xftpDescrPartSize = 200, xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupHistoryMultipleFiles :: HasCallStack => FilePath -> IO ()
testGroupHistoryMultipleFiles =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"]
xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"]
createGroup2 "team" alice bob
threadDelay 1000000
bob ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}"
bob <# "#team hi alice"
bob <# "/f #team ./tests/tmp/testfile_bob"
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile_bob) for #team"
alice <# "#team bob> hi alice"
alice <# "#team bob> sends file testfile_bob (2.0 MiB / 2097152 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
threadDelay 1000000
alice ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}"
alice <# "#team hey bob"
alice <# "/f #team ./tests/tmp/testfile_alice"
alice <## "use /fc 2 to cancel sending"
alice <## "completed uploading file 2 (testfile_alice) for #team"
bob <# "#team alice> hey bob"
bob <# "#team alice> sends file testfile_alice (1.0 MiB / 1048576 bytes)"
bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team bob> hi alice [>>]",
WithTime "#team bob> sends file testfile_bob (2.0 MiB / 2097152 bytes) [>>]",
"use /fr 1 [<dir>/ | <path>] to receive it [>>]",
WithTime "#team alice> hey bob [>>]",
WithTime "#team alice> sends file testfile_alice (1.0 MiB / 1048576 bytes) [>>]",
"use /fr 2 [<dir>/ | <path>] to receive it [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath
<### [ "saving file 1 from bob to ./tests/tmp/testfile_bob_1",
"started receiving file 1 (testfile_bob) from bob"
]
cath <## "completed receiving file 1 (testfile_bob) from bob"
srcBob <- B.readFile "./tests/tmp/testfile_bob"
destBob <- B.readFile "./tests/tmp/testfile_bob_1"
destBob `shouldBe` srcBob
cath ##> "/fr 2 ./tests/tmp"
cath
<### [ "saving file 2 from alice to ./tests/tmp/testfile_alice_1",
"started receiving file 2 (testfile_alice) from alice"
]
cath <## "completed receiving file 2 (testfile_alice) from alice"
srcAlice <- B.readFile "./tests/tmp/testfile_alice"
destAlice <- B.readFile "./tests/tmp/testfile_alice_1"
destAlice `shouldBe` srcAlice
cath ##> "/_get chat #1 count=100"
r <- chatF <$> getTermLine cath
r
`shouldContain` [ ((0, "hi alice"), Just "./tests/tmp/testfile_bob_1"),
((0, "hey bob"), Just "./tests/tmp/testfile_alice_1")
]
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupHistoryFileCancel :: HasCallStack => FilePath -> IO ()
testGroupHistoryFileCancel =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"]
xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"]
createGroup2 "team" alice bob
bob ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}"
bob <# "#team hi alice"
bob <# "/f #team ./tests/tmp/testfile_bob"
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile_bob) for #team"
alice <# "#team bob> hi alice"
alice <# "#team bob> sends file testfile_bob (2.0 MiB / 2097152 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob ##> "/fc 1"
bob <## "cancelled sending file 1 (testfile_bob) to alice"
alice <## "bob cancelled sending file 1 (testfile_bob)"
threadDelay 1000000
alice ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}"
alice <# "#team hey bob"
alice <# "/f #team ./tests/tmp/testfile_alice"
alice <## "use /fc 2 to cancel sending"
alice <## "completed uploading file 2 (testfile_alice) for #team"
bob <# "#team alice> hey bob"
bob <# "#team alice> sends file testfile_alice (1.0 MiB / 1048576 bytes)"
bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
alice ##> "/fc 2"
alice <## "cancelled sending file 2 (testfile_alice) to bob"
bob <## "alice cancelled sending file 2 (testfile_alice)"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team bob> hi alice [>>]",
WithTime "#team alice> hey bob [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupHistoryFileCancelNoText :: HasCallStack => FilePath -> IO ()
testGroupHistoryFileCancelNoText =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"]
xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"]
createGroup2 "team" alice bob
alice #> "#team hello"
bob <# "#team alice> hello"
-- bob file
bob #> "/f #team ./tests/tmp/testfile_bob"
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile_bob) for #team"
alice <# "#team bob> sends file testfile_bob (2.0 MiB / 2097152 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob ##> "/fc 1"
bob <## "cancelled sending file 1 (testfile_bob) to alice"
alice <## "bob cancelled sending file 1 (testfile_bob)"
-- alice file
alice #> "/f #team ./tests/tmp/testfile_alice"
alice <## "use /fc 2 to cancel sending"
alice <## "completed uploading file 2 (testfile_alice) for #team"
bob <# "#team alice> sends file testfile_alice (1.0 MiB / 1048576 bytes)"
bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
alice ##> "/fc 2"
alice <## "cancelled sending file 2 (testfile_alice) to bob"
bob <## "alice cancelled sending file 2 (testfile_alice)"
-- other messages are sent
bob #> "#team hey!"
alice <# "#team bob> hey!"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> hello [>>]",
WithTime "#team bob> hey! [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupHistoryQuotes :: HasCallStack => FilePath -> IO ()
testGroupHistoryQuotes =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team ALICE"
bob <# "#team alice> ALICE"
threadDelay 1000000
bob #> "#team BOB"
alice <# "#team bob> BOB"
threadDelay 1000000
alice `send` "> #team @alice (ALICE) 1"
alice <# "#team > alice ALICE"
alice <## " 1"
bob <# "#team alice> > alice ALICE"
bob <## " 1"
threadDelay 1000000
alice `send` "> #team @bob (BOB) 2"
alice <# "#team > bob BOB"
alice <## " 2"
bob <# "#team alice> > bob BOB"
bob <## " 2"
threadDelay 1000000
bob `send` "> #team @alice (ALICE) 3"
bob <# "#team > alice ALICE"
bob <## " 3"
alice <# "#team bob> > alice ALICE"
alice <## " 3"
threadDelay 1000000
bob `send` "> #team @bob (BOB) 4"
bob <# "#team > bob BOB"
bob <## " 4"
alice <# "#team bob> > bob BOB"
alice <## " 4"
alice
#$> ( "/_get chat #1 count=6",
chat',
[ ((1, "ALICE"), Nothing),
((0, "BOB"), Nothing),
((1, "1"), Just (1, "ALICE")),
((1, "2"), Just (0, "BOB")),
((0, "3"), Just (1, "ALICE")),
((0, "4"), Just (0, "BOB"))
]
)
bob
#$> ( "/_get chat #1 count=6",
chat',
[ ((0, "ALICE"), Nothing),
((1, "BOB"), Nothing),
((0, "1"), Just (0, "ALICE")),
((0, "2"), Just (1, "BOB")),
((1, "3"), Just (0, "ALICE")),
((1, "4"), Just (1, "BOB"))
]
)
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> ALICE [>>]",
WithTime "#team bob> BOB [>>]",
WithTime "#team alice> > alice ALICE [>>]",
" 1 [>>]",
WithTime "#team alice> > bob BOB [>>]",
" 2 [>>]",
WithTime "#team bob> > alice ALICE [>>]",
" 3 [>>]",
WithTime "#team bob> > bob BOB [>>]",
" 4 [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/_get chat #1 count=100"
r <- chat' <$> getTermLine cath
r
`shouldContain` [ ((0, "ALICE"), Nothing),
((0, "BOB"), Nothing),
((0, "1"), Just (0, "ALICE")),
((0, "2"), Just (0, "BOB")),
((0, "3"), Just (0, "ALICE")),
((0, "4"), Just (0, "BOB"))
]
testGroupHistoryDeletedMessage :: HasCallStack => FilePath -> IO ()
testGroupHistoryDeletedMessage =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup2 "team" alice bob
alice #> "#team hello"
bob <# "#team alice> hello"
threadDelay 1000000
bob #> "#team hey!"
alice <# "#team bob> hey!"
bobMsgId <- lastItemId bob
bob #$> ("/_delete item #1 " <> bobMsgId <> " broadcast", id, "message marked deleted")
alice <# "#team bob> [marked deleted] hey!"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> hello [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/_get chat #1 count=100"
r <- chat <$> getTermLine cath
r `shouldContain` [(0, "hello")]
r `shouldNotContain` [(0, "hey!")]
testGroupHistoryDisappearingMessage :: HasCallStack => FilePath -> IO ()
testGroupHistoryDisappearingMessage =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team 1"
bob <# "#team alice> 1"
threadDelay 1000000
-- 3 seconds so that messages 2 and 3 are not deleted for alice before sending history to cath
alice ##> "/set disappear #team on 3"
alice <## "updated group preferences:"
alice <## "Disappearing messages: on (3 sec)"
bob <## "alice updated group #team:"
bob <## "updated group preferences:"
bob <## "Disappearing messages: on (3 sec)"
bob #> "#team 2"
alice <# "#team bob> 2"
threadDelay 1000000
alice #> "#team 3"
bob <# "#team alice> 3"
threadDelay 1000000
alice ##> "/set disappear #team off"
alice <## "updated group preferences:"
alice <## "Disappearing messages: off"
bob <## "alice updated group #team:"
bob <## "updated group preferences:"
bob <## "Disappearing messages: off"
bob #> "#team 4"
alice <# "#team bob> 4"
connectUsers alice cath
addMember "team" alice cath GRAdmin
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
cath
<### [ "#team: you joined the group",
WithTime "#team alice> 1 [>>]",
WithTime "#team bob> 2 [>>]",
WithTime "#team alice> 3 [>>]",
WithTime "#team bob> 4 [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath ##> "/_get chat #1 count=100"
r1 <- chat <$> getTermLine cath
r1 `shouldContain` [(0, "1"), (0, "2"), (0, "3"), (0, "4")]
concurrentlyN_
[ do
alice <## "timed message deleted: 2"
alice <## "timed message deleted: 3",
do
bob <## "timed message deleted: 2"
bob <## "timed message deleted: 3",
do
cath <## "timed message deleted: 2"
cath <## "timed message deleted: 3"
]
cath ##> "/_get chat #1 count=100"
r2 <- chat <$> getTermLine cath
r2 `shouldContain` [(0, "1"), (0, "4")]
r2 `shouldNotContain` [(0, "2")]
r2 `shouldNotContain` [(0, "3")]

9
tests/ChatTests/Profiles.hs
View file

@ -1601,7 +1601,7 @@ testUpdateGroupPrefs =
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected")])
threadDelay 500000
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected")])
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}}}"
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}"
alice <## "updated group preferences:"
alice <## "Full deletion: on"
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on")])
@ -1610,7 +1610,7 @@ testUpdateGroupPrefs =
bob <## "Full deletion: on"
threadDelay 500000
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on")])
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}, \"directMessages\": {\"enable\": \"on\"}}}"
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}"
alice <## "updated group preferences:"
alice <## "Full deletion: off"
alice <## "Voice messages: off"
@ -1621,7 +1621,6 @@ testUpdateGroupPrefs =
bob <## "Voice messages: off"
threadDelay 500000
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off")])
-- alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}"
alice ##> "/set voice #team on"
alice <## "updated group preferences:"
alice <## "Voice messages: on"
@ -1632,7 +1631,7 @@ testUpdateGroupPrefs =
threadDelay 500000
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on")])
threadDelay 500000
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}}}"
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}"
-- no update
threadDelay 500000
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on")])
@ -1798,7 +1797,7 @@ testEnableTimedMessagesGroup =
\alice bob -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"timedMessages\": {\"enable\": \"on\", \"ttl\": 1}, \"directMessages\": {\"enable\": \"on\"}}}"
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"timedMessages\": {\"enable\": \"on\", \"ttl\": 1}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}"
alice <## "updated group preferences:"
alice <## "Disappearing messages: on (1 sec)"
bob <## "alice updated group #team:"

10
tests/ChatTests/Utils.hs
View file

@ -23,13 +23,15 @@ import Simplex.Chat.Protocol
import Simplex.Chat.Store.Profiles (getUserContactProfiles)
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow, withTransaction)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Version
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.Environment (lookupEnv, withArgs)
import System.FilePath ((</>))
import System.IO.Silently (capture_)
import System.Info (os)
import Test.Hspec
@ -219,7 +221,8 @@ groupFeatures'' =
((0, "Full deletion: off"), Nothing, Nothing),
((0, "Message reactions: on"), Nothing, Nothing),
((0, "Voice messages: on"), Nothing, Nothing),
((0, "Files and media: on"), Nothing, Nothing)
((0, "Files and media: on"), Nothing, Nothing),
((0, "Recent history: on"), Nothing, Nothing)
]
itemId :: Int -> String
@ -597,3 +600,6 @@ linkAnotherSchema link
| "simplex:/" `isPrefixOf` link =
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
| otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/"
xftpCLI :: [String] -> IO [String]
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)

120
tests/MessageBatching.hs Normal file
View file

@ -0,0 +1,120 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module MessageBatching (batchingTests) where
import Crypto.Number.Serialize (os2ip)
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Either (partitionEithers)
import Data.Int (Int64)
import Data.String (IsString (..))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Simplex.Chat.Messages.Batch
import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
import Simplex.Chat.Messages (SndMessage (..))
import Simplex.Chat.Protocol (SharedMsgId (..), maxChatMsgSize)
import Test.Hspec
batchingTests :: Spec
batchingTests = describe "message batching tests" $ do
testBatchingCorrectness
it "image x.msg.new and x.msg.file.descr should fit into single batch" testImageFitsSingleBatch
instance IsString SndMessage where
fromString s = SndMessage {msgId, sharedMsgId = SharedMsgId "", msgBody = LB.fromStrict s'}
where
s' = encodeUtf8 $ T.pack s
msgId = fromInteger $ os2ip s'
deriving instance Eq SndMessage
instance IsString ChatError where
fromString s = ChatError $ CEInternalError ("large message " <> show msgId)
where
s' = encodeUtf8 $ T.pack s
msgId = fromInteger (os2ip s') :: Int64
testBatchingCorrectness :: Spec
testBatchingCorrectness = describe "correctness tests" $ do
runBatcherTest 8 ["a"] [] ["a"]
runBatcherTest 8 ["a", "b"] [] ["[a,b]"]
runBatcherTest 8 ["a", "b", "c"] [] ["[a,b,c]"]
runBatcherTest 8 ["a", "bb", "c"] [] ["[a,bb,c]"]
runBatcherTest 8 ["a", "b", "c", "d"] [] ["a", "[b,c,d]"]
runBatcherTest 8 ["a", "bb", "c", "d"] [] ["a", "[bb,c,d]"]
runBatcherTest 8 ["a", "bb", "c", "de"] [] ["[a,bb]", "[c,de]"]
runBatcherTest 8 ["a", "b", "c", "d", "e"] [] ["[a,b]", "[c,d,e]"]
runBatcherTest 8 ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j"] [] ["a", "[b,c,d]", "[e,f,g]", "[h,i,j]"]
runBatcherTest 8 ["aaaaa"] [] ["aaaaa"]
runBatcherTest 8 ["8aaaaaaa"] [] ["8aaaaaaa"]
runBatcherTest 8 ["aaaa", "bbbb"] [] ["aaaa", "bbbb"]
runBatcherTest 8 ["aa", "bbb", "cc", "dd"] [] ["[aa,bbb]", "[cc,dd]"]
runBatcherTest 8 ["aa", "bbb", "cc", "dd", "eee", "fff", "gg", "hh"] [] ["aa", "[bbb,cc]", "[dd,eee]", "fff", "[gg,hh]"]
runBatcherTest 8 ["9aaaaaaaa"] ["9aaaaaaaa"] []
runBatcherTest 8 ["aaaaa", "bbb", "cc"] [] ["aaaaa", "[bbb,cc]"]
runBatcherTest 8 ["8aaaaaaa", "bbb", "cc"] [] ["8aaaaaaa", "[bbb,cc]"]
runBatcherTest 8 ["9aaaaaaaa", "bbb", "cc"] ["9aaaaaaaa"] ["[bbb,cc]"]
runBatcherTest 8 ["9aaaaaaaa", "bbb", "cc", "dd"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"]
runBatcherTest 8 ["9aaaaaaaa", "bbb", "cc", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"]
runBatcherTest 8 ["bbb", "cc", "aaaaa"] [] ["[bbb,cc]", "aaaaa"]
runBatcherTest 8 ["bbb", "cc", "8aaaaaaa"] [] ["[bbb,cc]", "8aaaaaaa"]
runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"]
runBatcherTest 8 ["bbb", "cc", "dd", "9aaaaaaaa"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"]
runBatcherTest 8 ["bbb", "cc", "dd", "e", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"]
runBatcherTest 8 ["bbb", "cc", "aaaaa", "dd"] [] ["[bbb,cc]", "aaaaa", "dd"]
runBatcherTest 8 ["bbb", "cc", "aaaaa", "dd", "e"] [] ["[bbb,cc]", "aaaaa", "[dd,e]"]
runBatcherTest 8 ["bbb", "cc", "8aaaaaaa", "dd"] [] ["[bbb,cc]", "8aaaaaaa", "dd"]
runBatcherTest 8 ["bbb", "cc", "8aaaaaaa", "dd", "e"] [] ["[bbb,cc]", "8aaaaaaa", "[dd,e]"]
runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"]
runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa", "dd"] ["9aaaaaaaa"] ["[bbb,cc]", "dd"]
runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"]
runBatcherTest 8 ["9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] []
runBatcherTest 8 ["8aaaaaaa", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"]
runBatcherTest 8 ["9aaaaaaaa", "8aaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"]
runBatcherTest 8 ["9aaaaaaaa", "10aaaaaaaa", "8aaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"]
runBatcherTest 8 ["bb", "cc", "dd", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
runBatcherTest 8 ["bb", "cc", "9aaaaaaaa", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["[bb,cc]", "dd"]
runBatcherTest 8 ["bb", "9aaaaaaaa", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
runBatcherTest 8 ["bb", "9aaaaaaaa", "cc", "10aaaaaaaa", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "cc", "dd"]
runBatcherTest 8 ["9aaaaaaaa", "bb", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
runBatcherTest 8 ["9aaaaaaaa", "bb", "10aaaaaaaa", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
runBatcherTest 8 ["9aaaaaaaa", "10aaaaaaaa", "bb", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
testImageFitsSingleBatch :: IO ()
testImageFitsSingleBatch = do
-- 14000 (limit for encoded image used in UI)
-- + 300 (remaining x.msg.new metadata, rounded up, actual example was 266)
let xMsgNewRoundedSize = 14300
-- size of x.msg.file.descr body for a file of size
-- 261_120 bytes (MAX_IMAGE_SIZE in UI), rounded up, example was 743
let descrRoundedSize = 800
let xMsgNewStr = LB.replicate xMsgNewRoundedSize 1
descrStr = LB.replicate descrRoundedSize 2
msg s = SndMessage {msgId = 0, sharedMsgId = SharedMsgId "", msgBody = s}
batched = "[" <> xMsgNewStr <> "," <> descrStr <> "]"
runBatcherTest' maxChatMsgSize [msg xMsgNewStr, msg descrStr] [] [batched]
runBatcherTest :: Int64 -> [SndMessage] -> [ChatError] -> [LB.ByteString] -> Spec
runBatcherTest maxLen msgs expectedErrors expectedBatches =
it
( (show (map (\SndMessage {msgBody} -> msgBody) msgs) <> ", limit " <> show maxLen <> ": should return ")
<> (show (length expectedErrors) <> " large, ")
<> (show (length expectedBatches) <> " batches")
)
(runBatcherTest' maxLen msgs expectedErrors expectedBatches)
runBatcherTest' :: Int64 -> [SndMessage] -> [ChatError] -> [LB.ByteString] -> IO ()
runBatcherTest' maxLen msgs expectedErrors expectedBatches = do
let (errors, batches) = partitionEithers $ batchMessages maxLen msgs
batchedStrs = map (\(MsgBatch builder _) -> toLazyByteString builder) batches
testErrors errors `shouldBe` testErrors expectedErrors
batchedStrs `shouldBe` expectedBatches
where
testErrors = map (\case ChatError (CEInternalError s) -> Just s; _ -> Nothing)

32
tests/ProtocolTests.hs
View file

@ -7,6 +7,7 @@ module ProtocolTests where
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
import Simplex.Chat.Protocol
import Simplex.Chat.Types
@ -14,8 +15,6 @@ import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (supportedSMPClientVRange)
import Simplex.Messaging.Version
import Test.Hspec
@ -62,13 +61,22 @@ quotedMsg =
(==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
s ==## msg = do
strDecode s `shouldBe` Right msg
parseAll strP s `shouldBe` Right msg
case parseChatMessages s of
[acMsg] -> case acMsg of
Right (ACMsg _ msg') -> case checkEncoding msg' of
Right msg'' -> msg'' `shouldBe` msg
Left e -> expectationFailure $ "checkEncoding error: " <> show e
Left e -> expectationFailure $ "parse error: " <> show e
_ -> expectationFailure "exactly one message expected"
(##==) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
s ##== msg =
J.eitherDecodeStrict' (strEncode msg)
`shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value)
s ##== msg = do
let r = encodeChatMessage msg
case r of
ECMEncoded encodedBody ->
J.eitherDecodeStrict' (LB.toStrict encodedBody)
`shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value)
ECMLarge -> expectationFailure $ "large message"
(##==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
s ##==## msg = do
@ -90,7 +98,7 @@ testChatPreferences :: Maybe Preferences
testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing, reactions = Just ReactionsPreference {allow = FAYes}}
testGroupPreferences :: Maybe GroupPreferences
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn}, files = Nothing, fullDelete = Nothing}
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn}, files = Nothing, fullDelete = Nothing, history = Nothing}
testProfile :: Profile
testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), contactLink = Nothing, preferences = testChatPreferences}
@ -122,7 +130,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)))
it "x.msg.new chat message with chat version range" $
"{\"v\":\"1-4\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
"{\"v\":\"1-5\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)))
it "x.msg.new quote" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}"
@ -232,13 +240,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
it "x.grp.mem.new with member chat version range" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-4\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-5\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
it "x.grp.mem.intro" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
it "x.grp.mem.intro with member chat version range" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-4\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-5\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
it "x.grp.mem.inv" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}"
@ -250,7 +258,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-4\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-5\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
it "x.grp.mem.info" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"

4
tests/SchemaDump.hs
View file

@ -73,7 +73,9 @@ skipComparisonForDownMigrations =
-- table and index definitions move down the file, so fields are re-created as not unique
"20230914_member_probes",
-- on down migration idx_connections_via_contact_uri_hash index moves down to the end of the file
"20231019_indexes"
"20231019_indexes",
-- table and indexes move down to the end of the file
"20231215_recreate_msg_deliveries"
]
getSchema :: FilePath -> FilePath -> IO String

2
tests/Test.hs
View file

@ -7,6 +7,7 @@ import Control.Logger.Simple
import Data.Time.Clock.System
import JSONTests
import MarkdownTests
import MessageBatching
import MobileTests
import ProtocolTests
import RemoteTests
@ -28,6 +29,7 @@ main = do
describe "SimpleX chat protocol" protocolTests
around tmpBracket $ describe "WebRTC encryption" webRTCTests
describe "Valid names" validNameTests
describe "Message batching" batchingTests
around testBracket $ do
describe "Mobile API Tests" mobileTests
describe "SimpleX chat client" chatTests