IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: batch send profile update (#3618)

Browse Source 
* core: batch send profile update

* redundant

* reorder

* remove type

* createSndMessages

* refactor

* batched create internal item

* create feature items for multiple contacts

* comments

* refactor call site

* synonim

* refactor createSndMessages

* more batching

* remove partitionWith

* unite filter and fold

* refactor

* refactor

* refactor

* fix merge

* add test

* rename

* refactor

* refactor

* withExceptT

* refactor

* refactor2

* remove notChanged

* deliver with sendMessagesB (#3646)

* deliver with sendMessagesB

* refactor

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
This commit is contained in:
spaced4ndy 2024-01-05 11:35:48 +04:00 committed by GitHub
parent 0ef2c55983
commit 9e87fe73a5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 188 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
apps/ios/SimpleXChat/ChatTypes.swift
View File

@ -172,7 +172,6 @@ public func fromLocalProfile (_ profile: LocalProfile) -> Profile {
} }
public struct UserProfileUpdateSummary: Decodable { public struct UserProfileUpdateSummary: Decodable {
public var notChanged: Int
public var updateSuccesses: Int public var updateSuccesses: Int
public var updateFailures: Int public var updateFailures: Int
public var changedContacts: [Contact] public var changedContacts: [Contact]

1
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt
View File

@ -1151,7 +1151,6 @@ data class LocalProfile(
@Serializable @Serializable
data class UserProfileUpdateSummary( data class UserProfileUpdateSummary(
val notChanged: Int,
val updateSuccesses: Int, val updateSuccesses: Int,
val updateFailures: Int, val updateFailures: Int,
val changedContacts: List<Contact> val changedContacts: List<Contact>

2
cabal.project
View File

@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/simplexmq.git location: https://github.com/simplex-chat/simplexmq.git
tag: d0588bd0ac23a459cbfc9a4789633014e91ffa19 tag: 6d4834f306963e2d3f2f62af212fe855ea9c7595
source-repository-package source-repository-package
type: git type: git

2
scripts/nix/sha256map.nix
View File

@ -1,5 +1,5 @@
{ {
"https://github.com/simplex-chat/simplexmq.git"."d0588bd0ac23a459cbfc9a4789633014e91ffa19" = "0b17qy74capb0jyli8f3pg1xi4aawhcgpmaz2ykl9g3605png1na"; "https://github.com/simplex-chat/simplexmq.git"."6d4834f306963e2d3f2f62af212fe855ea9c7595" = "1603nlzkncrl8kg9xb8yi4kjbk8d8gmyw7wzvlni7lgbf0hjrffz";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

232
src/Simplex/Chat.hs
View File

@ -24,7 +24,7 @@ import Control.Monad.Reader
import qualified Data.Aeson as J import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser) import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (bimap, first) import Data.Bifunctor (bimap, first, second)
import Data.ByteArray (ScrubbedBytes) import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteArray as BA import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
@ -37,6 +37,7 @@ import Data.Constraint (Dict (..))
import Data.Either (fromRight, lefts, partitionEithers, rights) import Data.Either (fromRight, lefts, partitionEithers, rights)
import Data.Fixed (div') import Data.Fixed (div')
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Functor.Identity
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (find, foldl', isSuffixOf, partition, sortOn) import Data.List (find, foldl', isSuffixOf, partition, sortOn)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|)) import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|))
@ -87,6 +88,7 @@ import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentCl
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew), execSQL, upMigration, withConnection) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew), execSQL, upMigration, withConnection)
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
@ -2136,31 +2138,41 @@ processChatCommand' vr = \case
| otherwise = do | otherwise = do
when (n /= n') $ checkValidName n' when (n /= n') $ checkValidName n'
-- read contacts before user update to correctly merge preferences -- read contacts before user update to correctly merge preferences
-- [incognito] filter out contacts with whom user has incognito connections contacts <- withStore' (`getUserContacts` user)
contacts <-
filter (\ct -> contactReady ct && contactActive ct && not (contactConnIncognito ct))
<$> withStore' (`getUserContacts` user)
user' <- updateUser user' <- updateUser
asks currentUser >>= atomically . (`writeTVar` Just user') asks currentUser >>= atomically . (`writeTVar` Just user')
withChatLock "updateProfile" . procCmd $ do withChatLock "updateProfile" . procCmd $ do
ChatConfig {logLevel} <- asks config let changedCts = foldr (addChangedProfileContact user') [] contacts
summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts idsEvts = map ctSndMsg changedCts
msgReqs_ <- zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
(errs, cts) <- partitionEithers . zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
unless (null errs) $ toView $ CRChatErrors (Just user) errs
let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts
createContactsSndFeatureItems user' changedCts'
let summary =
UserProfileUpdateSummary
{ updateSuccesses = length cts,
updateFailures = length errs,
changedContacts = map (\ChangedProfileContact {ct'} -> ct') changedCts'
}
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
where where
processAndCount user' ll s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts} ct = do -- [incognito] filter out contacts with whom user has incognito connections
let mergedProfile = userProfileToSend user Nothing $ Just ct addChangedProfileContact :: User -> Contact -> [ChangedProfileContact] -> [ChangedProfileContact]
ct' = updateMergedPreferences user' ct addChangedProfileContact user' ct changedCts = case contactSendConn_ ct' of
mergedProfile' = userProfileToSend user' Nothing $ Just ct' Left _ -> changedCts
if mergedProfile' == mergedProfile Right conn
then pure s {notChanged = notChanged + 1} | connIncognito conn || mergedProfile' == mergedProfile -> changedCts
else | otherwise -> ChangedProfileContact ct ct' mergedProfile' conn : changedCts
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'})
`catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'}
where where
notifyContact mergedProfile' ct' = do mergedProfile = userProfileToSend user Nothing $ Just ct
void $ sendDirectContactMessage ct' (XInfo mergedProfile') ct' = updateMergedPreferences user' ct
when (directOrUsed ct') $ createSndFeatureItems user' ct ct' mergedProfile' = userProfileToSend user' Nothing $ Just ct'
ctSndMsg :: ChangedProfileContact -> (ConnOrGroupId, ChatMsgEvent 'Json)
ctSndMsg ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, XInfo mergedProfile')
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError MsgReq
ctMsgReq ChangedProfileContact {conn} = fmap $ \SndMessage {msgId, msgBody} ->
(conn, MsgFlags {notification = hasNotification XInfo_}, msgBody, msgId)
updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse
updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct
updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
@ -2400,6 +2412,13 @@ processChatCommand' vr = \case
cReqHashes = bimap hash hash cReqSchemas cReqHashes = bimap hash hash cReqSchemas
hash = ConnReqUriHash . C.sha256Hash . strEncode hash = ConnReqUriHash . C.sha256Hash . strEncode
data ChangedProfileContact = ChangedProfileContact
{ ct :: Contact,
ct' :: Contact,
mergedProfile' :: Profile,
conn :: Connection
}
prepareGroupMsg :: forall m. ChatMonad m => User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe FileInvitation -> Maybe CITimed -> Bool -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) 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 prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ fInv_ timed_ live = case quotedItemId_ of
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
@ -5625,12 +5644,20 @@ deleteOrUpdateMemberRecord user@User {userId} member =
Nothing -> deleteGroupMember db user member Nothing -> deleteGroupMember db user member
sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => Contact -> ChatMsgEvent e -> m (SndMessage, Int64) sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => Contact -> ChatMsgEvent e -> m (SndMessage, Int64)
sendDirectContactMessage ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotReady ct sendDirectContactMessage ct chatMsgEvent = do
sendDirectContactMessage ct@Contact {activeConn = Just conn@Connection {connId, connStatus}, contactStatus} chatMsgEvent conn@Connection {connId} <- liftEither $ contactSendConn_ ct
| connStatus /= ConnReady && connStatus /= ConnSndReady = throwChatError $ CEContactNotReady ct sendDirectMessage conn chatMsgEvent (ConnectionId connId)
| contactStatus /= CSActive = throwChatError $ CEContactNotActive ct
| connDisabled conn = throwChatError $ CEContactDisabled ct contactSendConn_ :: Contact -> Either ChatError Connection
| otherwise = sendDirectMessage conn chatMsgEvent (ConnectionId connId) contactSendConn_ ct@Contact {activeConn} = case activeConn of
Nothing -> err $ CEContactNotReady ct
Just conn
| not (connReady conn) -> err $ CEContactNotReady ct
| not (contactActive ct) -> err $ CEContactNotActive ct
| connDisabled conn -> err $ CEContactDisabled ct
| otherwise -> Right conn
where
err = Left . ChatError
sendDirectMessage :: (MsgEncodingI e, ChatMonad m) => Connection -> ChatMsgEvent e -> ConnOrGroupId -> m (SndMessage, Int64) sendDirectMessage :: (MsgEncodingI e, ChatMonad m) => Connection -> ChatMsgEvent e -> ConnOrGroupId -> m (SndMessage, Int64)
sendDirectMessage conn chatMsgEvent connOrGroupId = do sendDirectMessage conn chatMsgEvent connOrGroupId = do
@ -5639,18 +5666,25 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
(msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId (msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do createSndMessage chatMsgEvent connOrGroupId =
liftEither . runIdentity =<< createSndMessages (Identity (connOrGroupId, chatMsgEvent))
createSndMessages :: forall e m t. (MsgEncodingI e, ChatMonad' m, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> m (t (Either ChatError SndMessage))
createSndMessages idsEvents = do
gVar <- asks random gVar <- asks random
vr <- chatVersionRange vr <- chatVersionRange
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr) withStoreBatch $ \db -> fmap (uncurry (createMsg db gVar vr)) idsEvents
where where
encodeMessage chatVRange sharedMsgId = createMsg db gVar chatVRange connOrGroupId evnt = runExceptT $ do
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} withExceptT ChatErrorStore $ createNewSndMessage db gVar connOrGroupId evnt (encodeMessage chatVRange evnt)
encodeMessage chatVRange evnt sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = evnt}
sendGroupMemberMessages :: forall e m. (MsgEncodingI e, ChatMonad m) => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> m () sendGroupMemberMessages :: forall e m. (MsgEncodingI e, ChatMonad m) => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> m ()
sendGroupMemberMessages user conn@Connection {connId} events groupId = do sendGroupMemberMessages user conn@Connection {connId} events groupId = do
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
(errs, msgs) <- partitionEithers <$> createSndMessages let idsEvts = L.map (GroupId groupId,) events
(errs, msgs) <- partitionEithers . L.toList <$> createSndMessages idsEvts
unless (null errs) $ toView $ CRChatErrors (Just user) errs unless (null errs) $ toView $ CRChatErrors (Just user) errs
unless (null msgs) $ do unless (null msgs) $ do
let (errs', msgBatches) = partitionEithers $ batchMessages maxChatMsgSize msgs let (errs', msgBatches) = partitionEithers $ batchMessages maxChatMsgSize msgs
@ -5665,16 +5699,6 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) MsgFlags {notification = True} batchBody agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) MsgFlags {notification = True} batchBody
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId} let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs
createSndMessages :: m [Either ChatError SndMessage]
createSndMessages = do
gVar <- asks random
vr <- chatVersionRange
withStoreBatch $ \db -> map (createMsg db gVar vr) (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 :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do directMessage chatMsgEvent = do
@ -5695,14 +5719,23 @@ deliverMessage' conn msgFlags msgBody msgId =
[r] -> liftEither r [r] -> liftEither r
rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs)
deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, LazyMsgBody, MessageId)] -> m [Either ChatError Int64] type MsgReq = (Connection, MsgFlags, LazyMsgBody, MessageId)
deliverMessages msgReqs = do
sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs) deliverMessages :: ChatMonad' m => [MsgReq] -> m [Either ChatError Int64]
deliverMessages = deliverMessagesB . map Right
deliverMessagesB :: ChatMonad' m => [Either ChatError MsgReq] -> m [Either ChatError Int64]
deliverMessagesB msgReqs = do
sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessagesB` map toAgent msgReqs)
withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent
where where
aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, LB.toStrict msgBody)) msgReqs toAgent = \case
prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,) Right (conn, msgFlags, msgBody, _msgId) -> Right (aConnId conn, msgFlags, LB.toStrict msgBody)
createDelivery :: DB.Connection -> ((Connection, MsgFlags, LazyMsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64) Left _ce -> Left (AP.INTERNAL "ChatError, skip") -- as long as it is Left, the agent batchers should just step over it
prepareBatch (Right req) (Right ar) = Right (req, ar)
prepareBatch (Left ce) _ = Left ce -- restore original ChatError
prepareBatch _ (Left ae) = Left $ ChatErrorAgent ae Nothing
createDelivery :: DB.Connection -> (MsgReq, AgentMsgId) -> IO (Either ChatError Int64)
createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) = createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) =
Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId
@ -5848,7 +5881,7 @@ saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem
ciId <- createNewSndChatItem db user cd msg content quotedItem itemTimed live createdAt ciId <- createNewSndChatItem db user cd msg content quotedItem itemTimed live createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure ciId pure ciId
liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemTimed live createdAt Nothing createdAt pure $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemTimed live createdAt Nothing createdAt
saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv) saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv)
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
@ -5862,14 +5895,14 @@ saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerT
(ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt (ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure (ciId, quotedItem) pure (ciId, quotedItem)
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt
mkChatItem :: forall c d. MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> IO (ChatItem c d) mkChatItem :: forall c d. MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs forwardedByMember currentTs = do mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs forwardedByMember currentTs =
let itemText = ciContentToText content let itemText = ciContentToText content
itemStatus = ciCreateStatus content itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file} in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
deleteDirectCI user ct ci@ChatItem {file} byUser timed = do deleteDirectCI user ct ci@ChatItem {file} byUser timed = do
@ -5982,6 +6015,15 @@ createSndFeatureItems user ct ct' =
CUPContact {preference} -> preference CUPContact {preference} -> preference
CUPUser {preference} -> preference CUPUser {preference} -> preference
createContactsSndFeatureItems :: forall m. ChatMonad m => User -> [ChangedProfileContact] -> m ()
createContactsSndFeatureItems user cts =
createContactsFeatureItems user cts' CDDirectSnd CISndChatFeature CISndChatPreference getPref
where
cts' = map (\ChangedProfileContact {ct, ct'} -> (ct, ct')) cts
getPref ContactUserPreference {userPreference} = case userPreference of
CUPContact {preference} -> preference
CUPUser {preference} -> preference
type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d
createFeatureItems :: createFeatureItems ::
@ -5995,24 +6037,44 @@ createFeatureItems ::
FeatureContent FeatureAllowed d -> FeatureContent FeatureAllowed d ->
(forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) ->
m () m ()
createFeatureItems user Contact {mergedPreferences = cups} ct'@Contact {mergedPreferences = cups'} chatDir ciFeature ciOffer getPref = createFeatureItems user ct ct' = createContactsFeatureItems user [(ct, ct')]
forM_ allChatFeatures $ \(ACF f) -> createItem f
createContactsFeatureItems ::
forall d m.
(MsgDirectionI d, ChatMonad m) =>
User ->
[(Contact, Contact)] ->
(Contact -> ChatDirection 'CTDirect d) ->
FeatureContent PrefEnabled d ->
FeatureContent FeatureAllowed d ->
(forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) ->
m ()
createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
let dirsCIContents = map contactChangedFeatures cts
(errs, acis) <- partitionEithers <$> createInternalItemsForChats user Nothing dirsCIContents
unless (null errs) $ toView $ CRChatErrors (Just user) errs
forM_ acis $ \aci -> toView $ CRNewChatItem user aci
where where
createItem :: forall f. FeatureI f => SChatFeature f -> m () contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, [CIContent d])
createItem f contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do
| state /= state' = create ciFeature state' let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures
| prefState /= prefState' = create ciOffer prefState' (chatDir ct', contents)
| otherwise = pure ()
where where
create :: FeatureContent a d -> (a, Maybe Int) -> m () featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d)
create ci (s, param) = createInternalChatItem user (chatDir ct') (ci f' s param) Nothing featureCIContent_ f
f' = chatFeature f | state /= state' = Just $ fContent ciFeature state'
state = featureState cup | prefState /= prefState' = Just $ fContent ciOffer prefState'
state' = featureState cup' | otherwise = Nothing
prefState = preferenceState $ getPref cup where
prefState' = preferenceState $ getPref cup' fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d
cup = getContactUserPreference f cups fContent ci (s, param) = ci f' s param
cup' = getContactUserPreference f cups' f' = chatFeature f
state = featureState cup
state' = featureState cup'
prefState = preferenceState $ getPref cup
prefState' = preferenceState $ getPref cup'
cup = getContactUserPreference f cups
cup' = getContactUserPreference f cups'
createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> CIContent d) -> GroupInfo -> GroupInfo -> m () createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> CIContent d) -> GroupInfo -> GroupInfo -> m ()
createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} =
@ -6026,15 +6088,35 @@ createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences
sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing}
createInternalChatItem :: forall c d m. (ChatTypeI c, MsgDirectionI d, ChatMonad m) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> m () createInternalChatItem :: (ChatTypeI c, MsgDirectionI d, ChatMonad m) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> m ()
createInternalChatItem user cd content itemTs_ = do createInternalChatItem user cd content itemTs_ =
createInternalItemsForChats user itemTs_ [(cd, [content])] >>= \case
[Right aci] -> toView $ CRNewChatItem user aci
[Left e] -> throwError e
rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs)
createInternalItemsForChats ::
forall c d m.
(ChatTypeI c, MsgDirectionI d, ChatMonad' m) =>
User ->
Maybe UTCTime ->
[(ChatDirection c d, [CIContent d])] ->
m [Either ChatError AChatItem]
createInternalItemsForChats user itemTs_ dirsCIContents = do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
let itemTs = fromMaybe createdAt itemTs_ let itemTs = fromMaybe createdAt itemTs_
ciId <- withStore' $ \db -> do void . withStoreBatch' $ \db -> map (uncurry $ updateChat db createdAt) dirsCIContents
when (ciRequiresAttention content) $ updateChatTs db user cd createdAt withStoreBatch' $ \db -> concatMap (uncurry $ createACIs db itemTs createdAt) dirsCIContents
createNewChatItemNoMsg db user cd content itemTs createdAt where
ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt updateChat :: DB.Connection -> UTCTime -> ChatDirection c d -> [CIContent d] -> IO ()
toView $ CRNewChatItem user (AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci) updateChat db createdAt cd contents
| any ciRequiresAttention contents = updateChatTs db user cd createdAt
| otherwise = pure ()
createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem]
createACIs db itemTs createdAt cd = map $ \content -> do
ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt
let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
getCreateActiveUser :: SQLiteStore -> Bool -> IO User getCreateActiveUser :: SQLiteStore -> Bool -> IO User
getCreateActiveUser st testView = do getCreateActiveUser st testView = do

3
src/Simplex/Chat/Controller.hs
View File

@ -894,8 +894,7 @@ data PendingSubStatus = PendingSubStatus
deriving (Show) deriving (Show)
data UserProfileUpdateSummary = UserProfileUpdateSummary data UserProfileUpdateSummary = UserProfileUpdateSummary
{ notChanged :: Int, { updateSuccesses :: Int,
updateSuccesses :: Int,
updateFailures :: Int, updateFailures :: Int,
changedContacts :: [Contact] changedContacts :: [Contact]
} }

28
tests/ChatTests/Profiles.hs
View File

@ -67,6 +67,7 @@ chatProfileTests = do
xit'' "enable timed messages with contact" testEnableTimedMessagesContact xit'' "enable timed messages with contact" testEnableTimedMessagesContact
it "enable timed messages in group" testEnableTimedMessagesGroup it "enable timed messages in group" testEnableTimedMessagesGroup
xit'' "timed messages enabled globally, contact turns on" testTimedMessagesEnabledGlobally xit'' "timed messages enabled globally, contact turns on" testTimedMessagesEnabledGlobally
it "update multiple user preferences for multiple contacts" testUpdateMultipleUserPrefs
testUpdateProfile :: HasCallStack => FilePath -> IO () testUpdateProfile :: HasCallStack => FilePath -> IO ()
testUpdateProfile = testUpdateProfile =
@ -1864,3 +1865,30 @@ testTimedMessagesEnabledGlobally =
bob <## "timed message deleted: hey" bob <## "timed message deleted: hey"
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)")]) alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)")])
bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)")])
testUpdateMultipleUserPrefs :: HasCallStack => FilePath -> IO ()
testUpdateMultipleUserPrefs = testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
connectUsers alice bob
alice #> "@bob hi bob"
bob <# "alice> hi bob"
connectUsers alice cath
alice #> "@cath hi cath"
cath <# "alice> hi cath"
alice ##> "/_profile 1 {\"displayName\": \"alice\", \"fullName\": \"Alice\", \"preferences\": {\"fullDelete\": {\"allow\": \"always\"}, \"reactions\": {\"allow\": \"no\"}, \"receipts\": {\"allow\": \"yes\", \"activated\": true}}}"
alice <## "updated preferences:"
alice <## "Full deletion allowed: always"
alice <## "Message reactions allowed: no"
bob <## "alice updated preferences for you:"
bob <## "Full deletion: enabled for you (you allow: default (no), contact allows: always)"
bob <## "Message reactions: off (you allow: default (yes), contact allows: no)"
cath <## "alice updated preferences for you:"
cath <## "Full deletion: enabled for you (you allow: default (no), contact allows: always)"
cath <## "Message reactions: off (you allow: default (yes), contact allows: no)"
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi bob"), (1, "Full deletion: enabled for contact"), (1, "Message reactions: off")])
alice #$> ("/_get chat @3 count=100", chat, chatFeatures <> [(1, "hi cath"), (1, "Full deletion: enabled for contact"), (1, "Message reactions: off")])