diff --git a/apps/ios/SimpleXChat/ChatTypes.swift b/apps/ios/SimpleXChat/ChatTypes.swift index 96281a5013..cd58b20002 100644 --- a/apps/ios/SimpleXChat/ChatTypes.swift +++ b/apps/ios/SimpleXChat/ChatTypes.swift @@ -172,7 +172,6 @@ public func fromLocalProfile (_ profile: LocalProfile) -> Profile { } public struct UserProfileUpdateSummary: Decodable { - public var notChanged: Int public var updateSuccesses: Int public var updateFailures: Int public var changedContacts: [Contact] diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt index b8d421b07b..ff7cfed0fd 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt @@ -1151,7 +1151,6 @@ data class LocalProfile( @Serializable data class UserProfileUpdateSummary( - val notChanged: Int, val updateSuccesses: Int, val updateFailures: Int, val changedContacts: List diff --git a/cabal.project b/cabal.project index dbd050bcf1..b3ecbe6b51 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: d0588bd0ac23a459cbfc9a4789633014e91ffa19 + tag: 6d4834f306963e2d3f2f62af212fe855ea9c7595 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index b22cef750e..233918be45 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b9605123d3..a9634a03cd 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -24,7 +24,7 @@ import Control.Monad.Reader import qualified Data.Aeson as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Bifunctor (bimap, first) +import Data.Bifunctor (bimap, first, second) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import qualified Data.ByteString.Base64 as B64 @@ -37,6 +37,7 @@ import Data.Constraint (Dict (..)) import Data.Either (fromRight, lefts, partitionEithers, rights) import Data.Fixed (div') import Data.Functor (($>)) +import Data.Functor.Identity import Data.Int (Int64) import Data.List (find, foldl', isSuffixOf, partition, sortOn) import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|)) @@ -88,6 +89,7 @@ import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentCl import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig) import Simplex.Messaging.Agent.Lock 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.DB (SlowQueryStats (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -455,8 +457,9 @@ processChatCommand' vr = \case withStore' getUsers >>= \case [] -> pure 1 users -> do - when (any (\User {localDisplayName = n} -> n == displayName) users) $ - throwChatError (CEUserExists displayName) + forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} -> + when (n == displayName) . throwChatError $ + if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} withAgent (\a -> createUser a smp xftp) ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts @@ -2207,31 +2210,41 @@ processChatCommand' vr = \case | otherwise = do when (n /= n') $ checkValidName n' -- read contacts before user update to correctly merge preferences - -- [incognito] filter out contacts with whom user has incognito connections - contacts <- - filter (\ct -> contactReady ct && contactActive ct && not (contactConnIncognito ct)) - <$> withStore' (`getUserContacts` user) + contacts <- withStore' (`getUserContacts` user) user' <- updateUser asks currentUser >>= atomically . (`writeTVar` Just user') withChatLock "updateProfile" . procCmd $ do - ChatConfig {logLevel} <- asks config - summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts + let changedCts = foldr (addChangedProfileContact user') [] 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 where - processAndCount user' ll s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts} ct = do - let mergedProfile = userProfileToSend user Nothing $ Just ct - ct' = updateMergedPreferences user' ct - mergedProfile' = userProfileToSend user' Nothing $ Just ct' - if mergedProfile' == mergedProfile - then pure s {notChanged = notChanged + 1} - else - 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'} + -- [incognito] filter out contacts with whom user has incognito connections + addChangedProfileContact :: User -> Contact -> [ChangedProfileContact] -> [ChangedProfileContact] + addChangedProfileContact user' ct changedCts = case contactSendConn_ ct' of + Left _ -> changedCts + Right conn + | connIncognito conn || mergedProfile' == mergedProfile -> changedCts + | otherwise -> ChangedProfileContact ct ct' mergedProfile' conn : changedCts where - notifyContact mergedProfile' ct' = do - void $ sendDirectContactMessage ct' (XInfo mergedProfile') - when (directOrUsed ct') $ createSndFeatureItems user' ct ct' + mergedProfile = userProfileToSend user Nothing $ Just ct + ct' = updateMergedPreferences user' 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 _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' @@ -2471,6 +2484,13 @@ processChatCommand' vr = \case cReqHashes = bimap hash hash cReqSchemas 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 user GroupInfo {groupId, membership} mc quotedItemId_ fInv_ timed_ live = case quotedItemId_ of Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) @@ -3430,6 +3450,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" MSG msgMeta _msgFlags msgBody -> do + checkIntegrityCreateItem (CDDirectRcv ct) msgMeta cmdId <- createAckCmd conn withAckMessage agentConnId cmdId msgMeta $ do (conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody @@ -3438,14 +3459,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = updateChatLock "directMessage" event case event of XMsgNew mc -> newContentMessage ct' mc msg msgMeta - XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta + XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct' sharedMsgId mContent msg msgMeta ttl live XMsgDel sharedMsgId _ -> messageDelete ct' sharedMsgId msg msgMeta XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct' sharedMsgId reaction add msg msgMeta -- TODO discontinue XFile XFile fInv -> processFileInvitation' ct' fInv msg msgMeta - XFileCancel sharedMsgId -> xFileCancel ct' sharedMsgId msgMeta - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName msgMeta + XFileCancel sharedMsgId -> xFileCancel ct' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName XInfo p -> xInfo ct' p XDirectDel -> xDirectDel ct' msg msgMeta XGrpInv gInv -> processGroupInvitation ct' gInv msg msgMeta @@ -3453,10 +3474,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct') probeHash XInfoProbeOk probe -> xInfoProbeOk (COMContact ct') probe XCallInv callId invitation -> xCallInv ct' callId invitation msg msgMeta - XCallOffer callId offer -> xCallOffer ct' callId offer msg msgMeta - XCallAnswer callId answer -> xCallAnswer ct' callId answer msg msgMeta - XCallExtra callId extraInfo -> xCallExtra ct' callId extraInfo msg msgMeta - XCallEnd callId -> xCallEnd ct' callId msg msgMeta + XCallOffer callId offer -> xCallOffer ct' callId offer msg + XCallAnswer callId answer -> xCallAnswer ct' callId answer msg + XCallExtra callId extraInfo -> xCallExtra ct' callId extraInfo msg + XCallEnd callId -> xCallEnd ct' callId msg BFileChunk sharedMsgId chunk -> bFileChunk ct' sharedMsgId chunk msgMeta _ -> messageError $ "unsupported message: " <> T.pack (show event) let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' @@ -3814,7 +3835,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = void $ sendDirectMessage imConn (XGrpMemCon memberId) (GroupId groupId) _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected" MSG msgMeta _msgFlags msgBody -> do - checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () + checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta cmdId <- createAckCmd conn let aChatMsgs = parseChatMessages msgBody withAckMessage agentConnId cmdId msgMeta $ do @@ -4305,7 +4326,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> m () newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete -- case content of @@ -4335,9 +4355,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ChatConfig {autoAcceptFileSize = sz} <- asks config when (sz > fileSize) $ receiveFile' user ft Nothing Nothing >>= toView - messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> MsgMeta -> m () - messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr msgMeta = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta + messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> m () + messageFileDescription Contact {contactId} sharedMsgId fileDescr = do fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId processFDMessage fileId fileDescr @@ -4380,7 +4399,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m () messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta updateRcvChatItem `catchCINotFound` \_ -> do -- This patches initial sharedMsgId into chat item when locally deleted chat item -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). @@ -4413,10 +4431,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () - messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta@MsgMeta {broker = (_, brokerTs)} = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta + messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta = do deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct) where + brokerTs = metaBrokerTs msgMeta deleteRcvChatItem = do CChatItem msgDir ci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId case msgDir of @@ -4584,7 +4602,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- TODO remove once XFile is discontinued processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m () processFileInvitation' ct fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta ChatConfig {fileChunkSize} <- asks config inline <- receiveInlineMode fInv Nothing fileChunkSize RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize @@ -4621,9 +4638,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = inline' receiveInstant = if mode == IFMOffer || (receiveInstant && maybe False isVoice mc_) then fileInline else Nothing _ -> pure Nothing - xFileCancel :: Contact -> SharedMsgId -> MsgMeta -> m () - xFileCancel ct@Contact {contactId} sharedMsgId msgMeta = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta + xFileCancel :: Contact -> SharedMsgId -> m () + xFileCancel Contact {contactId} sharedMsgId = do fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId ft <- withStore (\db -> getRcvFileTransfer db user fileId) unless (rcvFileCompleteOrCancelled ft) $ do @@ -4631,9 +4647,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ci <- withStore $ \db -> getChatItemByFileId db vr user fileId toView $ CRRcvFileSndCancelled user ci ft - xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m () - xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta + xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m () + xFileAcptInv ct sharedMsgId fileConnReq_ fName = do fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId assertSMPAcceptNotProhibited ci @@ -4767,7 +4782,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let Contact {localDisplayName = c, activeConn} = ct GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv forM_ activeConn $ \Connection {connId, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'} -> do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId -- [incognito] if direct connection with host is incognito, create membership using the same incognito profile @@ -4799,7 +4813,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> m () checkIntegrityCreateItem cd MsgMeta {integrity, broker = (_, brokerTs)} = case integrity of MsgOk -> pure () - MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs) + MsgError e -> + createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs) + `catchChatError` \_ -> pure () xInfo :: Contact -> Profile -> m () xInfo c p' = void $ processContactProfileUpdate c p' True @@ -4808,7 +4824,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xDirectDel c msg msgMeta = if directOrUsed c then do - checkIntegrityCreateItem (CDDirectRcv c) msgMeta ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted contactConns <- withStore' $ \db -> getContactConnections db userId ct' deleteAgentConnectionsAsync user $ map aConnId contactConns @@ -4968,7 +4983,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- to party accepting call xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> m () xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg@RcvMessage {sharedMsgId_} msgMeta = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta if featureAllowed SCFCalls forContact ct then do g <- asks random @@ -4995,9 +5009,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) -- to party initiating call - xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> MsgMeta -> m () - xCallOffer ct callId CallOffer {callType, rtcSession, callDhPubKey} msg msgMeta = do - msgCurrentCall ct callId "x.call.offer" msg msgMeta $ + xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> m () + xCallOffer ct callId CallOffer {callType, rtcSession, callDhPubKey} msg = do + msgCurrentCall ct callId "x.call.offer" msg $ \call -> case callState call of CallInvitationSent {localCallType, localDhPrivKey} -> do let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> localDhPrivKey) @@ -5010,9 +5024,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (Just call, Nothing) -- to party accepting call - xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> MsgMeta -> m () - xCallAnswer ct callId CallAnswer {rtcSession} msg msgMeta = do - msgCurrentCall ct callId "x.call.answer" msg msgMeta $ + xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> m () + xCallAnswer ct callId CallAnswer {rtcSession} msg = do + msgCurrentCall ct callId "x.call.answer" msg $ \call -> case callState call of CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession = rtcSession, sharedKey} @@ -5023,9 +5037,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (Just call, Nothing) -- to any call party - xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> MsgMeta -> m () - xCallExtra ct callId CallExtraInfo {rtcExtraInfo} msg msgMeta = do - msgCurrentCall ct callId "x.call.extra" msg msgMeta $ + xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> m () + xCallExtra ct callId CallExtraInfo {rtcExtraInfo} msg = do + msgCurrentCall ct callId "x.call.extra" msg $ \call -> case callState call of CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do -- TODO update the list of ice servers in peerCallSession @@ -5042,15 +5056,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (Just call, Nothing) -- to any call party - xCallEnd :: Contact -> CallId -> RcvMessage -> MsgMeta -> m () - xCallEnd ct callId msg msgMeta = - msgCurrentCall ct callId "x.call.end" msg msgMeta $ \Call {chatItemId} -> do + xCallEnd :: Contact -> CallId -> RcvMessage -> m () + xCallEnd ct callId msg = + msgCurrentCall ct callId "x.call.end" msg $ \Call {chatItemId} -> do toView $ CRCallEnded user ct (Nothing,) <$> callStatusItemContent user ct chatItemId WCSDisconnected - msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> MsgMeta -> (Call -> m (Maybe Call, Maybe ACIContent)) -> m () - msgCurrentCall ct@Contact {contactId = ctId'} callId' eventName RcvMessage {msgId} msgMeta action = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta + msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> (Call -> m (Maybe Call, Maybe ACIContent)) -> m () + msgCurrentCall ct@Contact {contactId = ctId'} callId' eventName RcvMessage {msgId} action = do calls <- asks currentCalls atomically (TM.lookup ctId' calls) >>= \case Nothing -> messageError $ eventName <> ": no current call" @@ -5705,12 +5718,20 @@ deleteOrUpdateMemberRecord user@User {userId} member = Nothing -> deleteGroupMember db user member sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => Contact -> ChatMsgEvent e -> m (SndMessage, Int64) -sendDirectContactMessage ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotReady ct -sendDirectContactMessage ct@Contact {activeConn = Just conn@Connection {connId, connStatus}, contactStatus} chatMsgEvent - | connStatus /= ConnReady && connStatus /= ConnSndReady = throwChatError $ CEContactNotReady ct - | contactStatus /= CSActive = throwChatError $ CEContactNotActive ct - | connDisabled conn = throwChatError $ CEContactDisabled ct - | otherwise = sendDirectMessage conn chatMsgEvent (ConnectionId connId) +sendDirectContactMessage ct chatMsgEvent = do + conn@Connection {connId} <- liftEither $ contactSendConn_ ct + sendDirectMessage conn chatMsgEvent (ConnectionId connId) + +contactSendConn_ :: Contact -> Either ChatError Connection +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 conn chatMsgEvent connOrGroupId = do @@ -5719,18 +5740,25 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do (msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId 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 vr <- chatVersionRange - withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr) + withStoreBatch $ \db -> fmap (uncurry (createMsg db gVar vr)) idsEvents where - encodeMessage chatVRange sharedMsgId = - encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} + createMsg db gVar chatVRange connOrGroupId evnt = runExceptT $ do + 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 user conn@Connection {connId} events groupId = do 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 msgs) $ do let (errs', msgBatches) = partitionEithers $ batchMessages maxChatMsgSize msgs @@ -5745,16 +5773,6 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do 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 - 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 chatMsgEvent = do @@ -5775,14 +5793,23 @@ deliverMessage' conn msgFlags msgBody msgId = [r] -> liftEither r rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) -deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, LazyMsgBody, MessageId)] -> m [Either ChatError Int64] -deliverMessages msgReqs = do - sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs) +type MsgReq = (Connection, MsgFlags, LazyMsgBody, MessageId) + +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 where - aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, LB.toStrict msgBody)) msgReqs - prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,) - createDelivery :: DB.Connection -> ((Connection, MsgFlags, LazyMsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64) + toAgent = \case + Right (conn, msgFlags, msgBody, _msgId) -> Right (aConnId conn, msgFlags, LB.toStrict msgBody) + 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) = Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId @@ -5928,7 +5955,7 @@ saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem ciId <- createNewSndChatItem db user cd msg content quotedItem itemTimed live createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt 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, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv) saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = @@ -5942,14 +5969,14 @@ saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerT (ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt 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 cd ciId content file quotedItem sharedMsgId itemTimed live itemTs forwardedByMember currentTs = do +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 = let itemText = ciContentToText content itemStatus = ciCreateStatus content 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 user ct ci@ChatItem {file} byUser timed = do @@ -6070,6 +6097,15 @@ createSndFeatureItems user ct ct' = CUPContact {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 createFeatureItems :: @@ -6083,24 +6119,44 @@ createFeatureItems :: FeatureContent FeatureAllowed d -> (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> m () -createFeatureItems user Contact {mergedPreferences = cups} ct'@Contact {mergedPreferences = cups'} chatDir ciFeature ciOffer getPref = - forM_ allChatFeatures $ \(ACF f) -> createItem f +createFeatureItems user ct ct' = createContactsFeatureItems user [(ct, ct')] + +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 - createItem :: forall f. FeatureI f => SChatFeature f -> m () - createItem f - | state /= state' = create ciFeature state' - | prefState /= prefState' = create ciOffer prefState' - | otherwise = pure () + contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, [CIContent d]) + contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do + let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures + (chatDir ct', contents) where - create :: FeatureContent a d -> (a, Maybe Int) -> m () - create ci (s, param) = createInternalChatItem user (chatDir ct') (ci f' s param) Nothing - 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' + featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d) + featureCIContent_ f + | state /= state' = Just $ fContent ciFeature state' + | prefState /= prefState' = Just $ fContent ciOffer prefState' + | otherwise = Nothing + where + fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d + fContent ci (s, param) = ci f' s param + 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 user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = @@ -6114,15 +6170,35 @@ createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool 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 user cd content itemTs_ = do +createInternalChatItem :: (ChatTypeI c, MsgDirectionI d, ChatMonad m) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> m () +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 let itemTs = fromMaybe createdAt itemTs_ - ciId <- withStore' $ \db -> do - when (ciRequiresAttention content) $ updateChatTs db user cd createdAt - createNewChatItemNoMsg db user cd content itemTs createdAt - ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt - toView $ CRNewChatItem user (AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci) + void . withStoreBatch' $ \db -> map (uncurry $ updateChat db createdAt) dirsCIContents + withStoreBatch' $ \db -> concatMap (uncurry $ createACIs db itemTs createdAt) dirsCIContents + where + updateChat :: DB.Connection -> UTCTime -> ChatDirection c d -> [CIContent d] -> IO () + 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 createLocalChatItem :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTLocal d -> CIContent d -> UTCTime -> m ChatItemId createLocalChatItem user cd content createdAt = do diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 011c180ac9..83800c2d4e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -897,8 +897,7 @@ data PendingSubStatus = PendingSubStatus deriving (Show) data UserProfileUpdateSummary = UserProfileUpdateSummary - { notChanged :: Int, - updateSuccesses :: Int, + { updateSuccesses :: Int, updateFailures :: Int, changedContacts :: [Contact] } diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 6813a4cc72..afa9fb3cff 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -67,6 +67,7 @@ chatProfileTests = do xit'' "enable timed messages with contact" testEnableTimedMessagesContact it "enable timed messages in group" testEnableTimedMessagesGroup xit'' "timed messages enabled globally, contact turns on" testTimedMessagesEnabledGlobally + it "update multiple user preferences for multiple contacts" testUpdateMultipleUserPrefs testUpdateProfile :: HasCallStack => FilePath -> IO () testUpdateProfile = @@ -1864,3 +1865,30 @@ testTimedMessagesEnabledGlobally = bob <## "timed message deleted: hey" 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)")]) + +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")])