mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-04-26 21:45:52 +00:00
core: do not subscribe to new connections from iOS NSE (subscribe=off flag), subscribe in app when it activates (#3016)
* Trace auto-subs flag * Replace Bool with SubscriptionMode * Add subscriptionMode to chat controller * Start using subscriptionMode in event handlers * Add need_subs to chat connections * Add onlyNeeded to subscribeUserConnections * Post-rebase fixes * Pass onlyNeeded to Store functions * Drop needs_sub for connections registered with agent * update simplexmq, fix activate * fix rebase, reduce diff * fix rebase, tests * fix rebase, executeMany, always subscribe on activate * test * update queries * Update src/Simplex/Chat.hs Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * unset connections to subscribe on start * update simplexmq --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
7b582b2cf9
commit
2dff6c8859
+127
-67
@@ -89,7 +89,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (base64P)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), EntityId, ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI, SProtocolType (..), UserProtocol, userProtocol)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), EntityId, ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI, SProtocolType (..), SubscriptionMode (..), UserProtocol, userProtocol)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport.Client (defaultSocksProxy)
|
||||
@@ -194,6 +194,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
inputQ <- newTBQueueIO tbqSize
|
||||
outputQ <- newTBQueueIO tbqSize
|
||||
notifyQ <- newTBQueueIO tbqSize
|
||||
subscriptionMode <- newTVarIO SMSubscribe
|
||||
chatLock <- newEmptyTMVarIO
|
||||
sndFiles <- newTVarIO M.empty
|
||||
rcvFiles <- newTVarIO M.empty
|
||||
@@ -207,7 +208,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
showLiveItems <- newTVarIO False
|
||||
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
|
||||
tempDirectory <- newTVarIO tempDir
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile}
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
configServers =
|
||||
@@ -246,6 +247,8 @@ cfgServers = \case
|
||||
startChatController :: forall m. ChatMonad' m => Bool -> Bool -> Bool -> m (Async ())
|
||||
startChatController subConns enableExpireCIs startXFTPWorkers = do
|
||||
asks smpAgent >>= resumeAgentClient
|
||||
unless subConns $
|
||||
chatWriteVar subscriptionMode SMOnlyCreate
|
||||
users <- fromRight [] <$> runExceptT (withStoreCtx' (Just "startChatController, getUsers") getUsers)
|
||||
restoreCalls
|
||||
s <- asks agentAsync
|
||||
@@ -255,7 +258,7 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
|
||||
a1 <- async $ race_ notificationSubscriber agentSubscriber
|
||||
a2 <-
|
||||
if subConns
|
||||
then Just <$> async (subscribeUsers users)
|
||||
then Just <$> async (subscribeUsers False users)
|
||||
else pure Nothing
|
||||
atomically . writeTVar s $ Just (a1, a2)
|
||||
when startXFTPWorkers $ do
|
||||
@@ -283,14 +286,14 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
|
||||
startExpireCIThread user
|
||||
setExpireCIFlag user True
|
||||
|
||||
subscribeUsers :: forall m. ChatMonad' m => [User] -> m ()
|
||||
subscribeUsers users = do
|
||||
subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m ()
|
||||
subscribeUsers onlyNeeded users = do
|
||||
let (us, us') = partition activeUser users
|
||||
subscribe us
|
||||
subscribe us'
|
||||
where
|
||||
subscribe :: [User] -> m ()
|
||||
subscribe = mapM_ $ runExceptT . subscribeUserConnections Agent.subscribeConnections
|
||||
subscribe = mapM_ $ runExceptT . subscribeUserConnections onlyNeeded Agent.subscribeConnections
|
||||
|
||||
startFilesToReceive :: forall m. ChatMonad' m => [User] -> m ()
|
||||
startFilesToReceive users = do
|
||||
@@ -464,14 +467,16 @@ processChatCommand = \case
|
||||
APIActivateChat -> withUser $ \_ -> do
|
||||
restoreCalls
|
||||
withAgent foregroundAgent
|
||||
withStoreCtx' (Just "APIActivateChat, getUsers") getUsers >>= void . forkIO . startFilesToReceive
|
||||
users <- withStoreCtx' (Just "APIActivateChat, getUsers") getUsers
|
||||
void . forkIO $ subscribeUsers True users
|
||||
void . forkIO $ startFilesToReceive users
|
||||
setAllExpireCIFlags True
|
||||
ok_
|
||||
APISuspendChat t -> do
|
||||
setAllExpireCIFlags False
|
||||
withAgent (`suspendAgent` t)
|
||||
ok_
|
||||
ResubscribeAllConnections -> withStoreCtx' (Just "ResubscribeAllConnections, getUsers") getUsers >>= subscribeUsers >> ok_
|
||||
ResubscribeAllConnections -> withStoreCtx' (Just "ResubscribeAllConnections, getUsers") getUsers >>= subscribeUsers False >> ok_
|
||||
-- has to be called before StartChat
|
||||
SetTempFolder tf -> do
|
||||
createDirectoryIfMissing True tf
|
||||
@@ -567,15 +572,16 @@ processChatCommand = \case
|
||||
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
|
||||
smpSndFileTransfer (CryptoFile file Nothing) fileSize fileInline = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
(agentConnId_, fileConnReq) <-
|
||||
if isJust fileInline
|
||||
then pure (Nothing, Nothing)
|
||||
else bimap Just Just <$> withAgent (\a -> createConnection a (aUserId user) True SCMInvitation Nothing)
|
||||
else bimap Just Just <$> withAgent (\a -> createConnection a (aUserId user) True SCMInvitation Nothing subMode)
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize
|
||||
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize subMode
|
||||
fileStatus <- case fileInline of
|
||||
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
|
||||
_ -> pure CIFSSndStored
|
||||
@@ -1273,8 +1279,9 @@ processChatCommand = \case
|
||||
APIAddContact userId incognito -> withUserId userId $ \user -> withChatLock "addContact" . procCmd $ do
|
||||
-- [incognito] generate profile for connection
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing
|
||||
conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing subMode
|
||||
conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile subMode
|
||||
toView $ CRNewContactConnection user conn
|
||||
pure $ CRInvitation user cReq conn
|
||||
AddContact incognito -> withUser $ \User {userId} ->
|
||||
@@ -1295,12 +1302,13 @@ processChatCommand = \case
|
||||
Just conn' -> pure $ CRConnectionIncognitoUpdated user conn'
|
||||
Nothing -> throwChatError CEConnectionIncognitoChangeProhibited
|
||||
APIConnect userId incognito (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- [incognito] generate profile to send
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let profileToSend = userProfileToSend user incognitoProfile Nothing
|
||||
dm <- directMessage $ XInfo profileToSend
|
||||
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm
|
||||
conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnJoined $ incognitoProfile $> profileToSend
|
||||
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm subMode
|
||||
conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnJoined (incognitoProfile $> profileToSend) subMode
|
||||
toView $ CRNewContactConnection user conn
|
||||
pure $ CRSentConfirmation user
|
||||
APIConnect userId incognito (Just (ACR SCMContact cReq)) -> withUserId userId $ \user -> connectViaContact user incognito cReq
|
||||
@@ -1317,8 +1325,9 @@ processChatCommand = \case
|
||||
ListContacts -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APIListContacts userId
|
||||
APICreateMyAddress userId -> withUserId userId $ \user -> withChatLock "createMyAddress" . procCmd $ do
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact Nothing
|
||||
withStore $ \db -> createUserContactLink db user connId cReq
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact Nothing subMode
|
||||
withStore $ \db -> createUserContactLink db user connId cReq subMode
|
||||
pure $ CRUserContactLinkCreated user cReq
|
||||
CreateMyAddress -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APICreateMyAddress userId
|
||||
@@ -1423,8 +1432,9 @@ processChatCommand = \case
|
||||
case contactMember contact members of
|
||||
Nothing -> do
|
||||
gVar <- asks idsDrg
|
||||
(agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing
|
||||
member <- withStore $ \db -> createNewContactMember db gVar user groupId contact memRole agentConnId cReq
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
(agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing subMode
|
||||
member <- withStore $ \db -> createNewContactMember db gVar user groupId contact memRole agentConnId cReq subMode
|
||||
sendInvitation member cReq
|
||||
pure $ CRSentGroupInvitation user gInfo contact member
|
||||
Just member@GroupMember {groupMemberId, memberStatus, memberRole = mRole}
|
||||
@@ -1443,10 +1453,11 @@ processChatCommand = \case
|
||||
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
|
||||
Contact {activeConn = Connection {peerChatVRange}} = ct
|
||||
withChatLock "joinGroup" . procCmd $ do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XGrpAcpt (memberId (membership :: GroupMember))
|
||||
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm
|
||||
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode
|
||||
withStore' $ \db -> do
|
||||
createMemberConnection db userId fromMember agentConnId peerChatVRange
|
||||
createMemberConnection db userId fromMember agentConnId peerChatVRange subMode
|
||||
updateGroupMemberStatus db userId fromMember GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
updateCIGroupInvitationStatus user
|
||||
@@ -1557,9 +1568,10 @@ processChatCommand = \case
|
||||
assertUserGroupRole gInfo GRAdmin
|
||||
when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
|
||||
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact $ Just crClientData
|
||||
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact (Just crClientData) subMode
|
||||
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode
|
||||
pure $ CRGroupLinkCreated user gInfo cReq mRole
|
||||
APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
@@ -1845,13 +1857,14 @@ processChatCommand = \case
|
||||
(_, xContactId_) -> procCmd $ do
|
||||
let randomXContactId = XContactId <$> drgRandomBytes 16
|
||||
xContactId <- maybe randomXContactId pure xContactId_
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- [incognito] generate profile to send
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let profileToSend = userProfileToSend user incognitoProfile Nothing
|
||||
dm <- directMessage (XContact profileToSend $ Just xContactId)
|
||||
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm
|
||||
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm subMode
|
||||
let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
|
||||
conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId
|
||||
conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode
|
||||
toView $ CRNewContactConnection user conn
|
||||
pure $ CRSentInvitation user incognitoProfile
|
||||
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
|
||||
@@ -2240,9 +2253,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
case (xftpRcvFile, fileConnReq) of
|
||||
-- direct file protocol
|
||||
(Nothing, Just connReq) -> do
|
||||
connIds <- joinAgentConnectionAsync user True connReq =<< directMessage (XFileAcpt fName)
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XFileAcpt fName
|
||||
connIds <- joinAgentConnectionAsync user True connReq dm subMode
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
|
||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath subMode
|
||||
-- XFTP
|
||||
(Just XFTPRcvFile {cryptoArgs}, _) -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName False
|
||||
@@ -2283,8 +2298,9 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
| fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
| otherwise -> do
|
||||
-- accepting via a new connection
|
||||
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation
|
||||
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnNew filePath
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode
|
||||
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnNew filePath subMode
|
||||
receiveInline :: m Bool
|
||||
receiveInline = do
|
||||
ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config
|
||||
@@ -2356,17 +2372,19 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
|
||||
|
||||
acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> m Contact
|
||||
acceptContactRequest user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId} incognitoProfile = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let profileToSend = profileToSendOnAccept user incognitoProfile
|
||||
dm <- directMessage $ XInfo profileToSend
|
||||
acId <- withAgent $ \a -> acceptContact a True invId dm
|
||||
withStore' $ \db -> createAcceptedContact db user acId cReqChatVRange cName profileId cp userContactLinkId xContactId incognitoProfile
|
||||
acId <- withAgent $ \a -> acceptContact a True invId dm subMode
|
||||
withStore' $ \db -> createAcceptedContact db user acId cReqChatVRange cName profileId cp userContactLinkId xContactId incognitoProfile subMode
|
||||
|
||||
acceptContactRequestAsync :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> m Contact
|
||||
acceptContactRequestAsync user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let profileToSend = profileToSendOnAccept user incognitoProfile
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True invId $ XInfo profileToSend
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode
|
||||
withStore' $ \db -> do
|
||||
ct@Contact {activeConn = Connection {connId}} <- createAcceptedContact db user acId cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile
|
||||
ct@Contact {activeConn = Connection {connId}} <- createAcceptedContact db user acId cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile subMode
|
||||
setCommandConnId db user cmdId connId
|
||||
pure ct
|
||||
|
||||
@@ -2413,18 +2431,28 @@ agentSubscriber = do
|
||||
|
||||
type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
|
||||
|
||||
subscribeUserConnections :: forall m. ChatMonad m => AgentBatchSubscribe m -> User -> m ()
|
||||
subscribeUserConnections agentBatchSubscribe user@User {userId} = do
|
||||
subscribeUserConnections :: forall m. ChatMonad m => Bool -> AgentBatchSubscribe m -> User -> m ()
|
||||
subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
|
||||
-- get user connections
|
||||
ce <- asks $ subscriptionEvents . config
|
||||
(ctConns, cts) <- getContactConns
|
||||
(ucConns, ucs) <- getUserContactLinkConns
|
||||
(gs, mConns, ms) <- getGroupMemberConns
|
||||
(sftConns, sfts) <- getSndFileTransferConns
|
||||
(rftConns, rfts) <- getRcvFileTransferConns
|
||||
(pcConns, pcs) <- getPendingContactConns
|
||||
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
|
||||
if onlyNeeded
|
||||
then do
|
||||
(conns, entities) <- withStore' getConnectionsToSubscribe
|
||||
let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities
|
||||
pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
|
||||
else do
|
||||
withStore' unsetConnectionToSubscribe
|
||||
(ctConns, cts) <- getContactConns
|
||||
(ucConns, ucs) <- getUserContactLinkConns
|
||||
(gs, mConns, ms) <- getGroupMemberConns
|
||||
(sftConns, sfts) <- getSndFileTransferConns
|
||||
(rftConns, rfts) <- getRcvFileTransferConns
|
||||
(pcConns, pcs) <- getPendingContactConns
|
||||
let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns]
|
||||
pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs)
|
||||
-- subscribe using batched commands
|
||||
rs <- withAgent (`agentBatchSubscribe` concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns])
|
||||
rs <- withAgent $ \a -> agentBatchSubscribe a conns
|
||||
-- send connection events to view
|
||||
contactSubsToView rs cts ce
|
||||
contactLinkSubsToView rs ucs
|
||||
@@ -2433,6 +2461,29 @@ subscribeUserConnections agentBatchSubscribe user@User {userId} = do
|
||||
rcvFileSubsToView rs rfts
|
||||
pendingConnSubsToView rs pcs
|
||||
where
|
||||
addEntity (cts, ucs, ms, sfts, rfts, pcs) = \case
|
||||
RcvDirectMsgConnection c (Just ct) -> let cts' = addConn c ct cts in (cts', ucs, ms, sfts, rfts, pcs)
|
||||
RcvDirectMsgConnection c Nothing -> let pcs' = addConn c (toPCC c) pcs in (cts, ucs, ms, sfts, rfts, pcs')
|
||||
RcvGroupMsgConnection c _g m -> let ms' = addConn c m ms in (cts, ucs, ms', sfts, rfts, pcs)
|
||||
SndFileConnection c sft -> let sfts' = addConn c sft sfts in (cts, ucs, ms, sfts', rfts, pcs)
|
||||
RcvFileConnection c rft -> let rfts' = addConn c rft rfts in (cts, ucs, ms, sfts, rfts', pcs)
|
||||
UserContactConnection c uc -> let ucs' = addConn c uc ucs in (cts, ucs', ms, sfts, rfts, pcs)
|
||||
addConn :: Connection -> a -> Map ConnId a -> Map ConnId a
|
||||
addConn = M.insert . aConnId
|
||||
toPCC Connection {connId, agentConnId, connStatus, viaUserContactLink, groupLinkId, customUserProfileId, localAlias, createdAt} =
|
||||
PendingContactConnection
|
||||
{ pccConnId = connId,
|
||||
pccAgentConnId = agentConnId,
|
||||
pccConnStatus = connStatus,
|
||||
viaContactUri = False,
|
||||
viaUserContactLink,
|
||||
groupLinkId,
|
||||
customUserProfileId,
|
||||
connReqInv = Nothing,
|
||||
localAlias,
|
||||
createdAt,
|
||||
updatedAt = createdAt
|
||||
}
|
||||
getContactConns :: m ([ConnId], Map ConnId Contact)
|
||||
getContactConns = do
|
||||
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts
|
||||
@@ -2971,9 +3022,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
gVar <- asks idsDrg
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds peerChatVRange
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds peerChatVRange subMode
|
||||
_ -> pure ()
|
||||
Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) ->
|
||||
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
|
||||
@@ -3920,8 +3972,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
then unless cancelled $ case fileConnReq_ of
|
||||
-- receiving via a separate connection
|
||||
Just fileConnReq -> do
|
||||
connIds <- joinAgentConnectionAsync user True fileConnReq =<< directMessage XOk
|
||||
withStore' $ \db -> createSndDirectFTConnection db user fileId connIds
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage XOk
|
||||
connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode
|
||||
withStore' $ \db -> createSndDirectFTConnection db user fileId connIds subMode
|
||||
-- receiving inline
|
||||
_ -> do
|
||||
event <- withStore $ \db -> do
|
||||
@@ -4015,10 +4069,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
if fName == fileName
|
||||
then unless cancelled $ case (fileConnReq_, activeConn) of
|
||||
(Just fileConnReq, _) -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- receiving via a separate connection
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
connIds <- joinAgentConnectionAsync user True fileConnReq =<< directMessage XOk
|
||||
withStore' $ \db -> createSndGroupFileTransferConnection db user fileId connIds m
|
||||
dm <- directMessage XOk
|
||||
connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode
|
||||
withStore' $ \db -> createSndGroupFileTransferConnection db user fileId connIds m subMode
|
||||
(_, Just conn) -> do
|
||||
-- receiving inline
|
||||
event <- withStore $ \db -> do
|
||||
@@ -4049,9 +4105,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
|
||||
if sameGroupLinkId groupLinkId groupLinkId'
|
||||
then do
|
||||
connIds <- joinAgentConnectionAsync user True connRequest =<< directMessage (XGrpAcpt memberId)
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XGrpAcpt memberId
|
||||
connIds <- joinAgentConnectionAsync user True connRequest dm subMode
|
||||
withStore' $ \db -> do
|
||||
createMemberConnectionAsync db user hostId connIds peerChatVRange
|
||||
createMemberConnectionAsync db user hostId connIds peerChatVRange subMode
|
||||
updateGroupMemberStatusById db userId hostId GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
|
||||
@@ -4285,18 +4343,19 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
then messageWarning "x.grp.mem.intro ignored: member already exists"
|
||||
else do
|
||||
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
|
||||
groupConnIds <- createConn
|
||||
groupConnIds <- createConn subMode
|
||||
directConnIds <- case memberChatVRange of
|
||||
Nothing -> Just <$> createConn
|
||||
Nothing -> Just <$> createConn subMode
|
||||
Just mcvr
|
||||
| isCompatibleRange (fromChatVRange mcvr) groupNoDirectVRange -> Just <$> createConn -- pure Nothing
|
||||
| otherwise -> Just <$> createConn
|
||||
| isCompatibleRange (fromChatVRange mcvr) groupNoDirectVRange -> Just <$> createConn subMode -- pure Nothing
|
||||
| otherwise -> Just <$> createConn subMode
|
||||
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
where
|
||||
createConn = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
|
||||
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation subMode
|
||||
|
||||
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m ()
|
||||
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
|
||||
@@ -4330,14 +4389,15 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
Nothing -> withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced
|
||||
Just m' -> pure m'
|
||||
withStore' $ \db -> saveMemberInvitation db toMember introInv
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- [incognito] send membership incognito profile, create direct connection as incognito
|
||||
dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
|
||||
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
||||
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm
|
||||
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode
|
||||
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode
|
||||
|
||||
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m ()
|
||||
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta
|
||||
@@ -4838,16 +4898,16 @@ cancelCIFile user file_ =
|
||||
fileAgentConnIds <- cancelFile' user (mkCIFileInfo file) True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
|
||||
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
|
||||
createAgentConnectionAsync user cmdFunction enableNtfs cMode = do
|
||||
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> m (CommandId, ConnId)
|
||||
createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user Nothing cmdFunction
|
||||
connId <- withAgent $ \a -> createConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cMode
|
||||
connId <- withAgent $ \a -> createConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cMode subMode
|
||||
pure (cmdId, connId)
|
||||
|
||||
joinAgentConnectionAsync :: ChatMonad m => User -> Bool -> ConnectionRequestUri c -> ConnInfo -> m (CommandId, ConnId)
|
||||
joinAgentConnectionAsync user enableNtfs cReqUri cInfo = do
|
||||
joinAgentConnectionAsync :: ChatMonad m => User -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> m (CommandId, ConnId)
|
||||
joinAgentConnectionAsync user enableNtfs cReqUri cInfo subMode = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user Nothing CFJoinConn
|
||||
connId <- withAgent $ \a -> joinConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cReqUri cInfo
|
||||
connId <- withAgent $ \a -> joinConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cReqUri cInfo subMode
|
||||
pure (cmdId, connId)
|
||||
|
||||
allowAgentConnectionAsync :: (MsgEncodingI e, ChatMonad m) => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> m ()
|
||||
@@ -4857,11 +4917,11 @@ allowAgentConnectionAsync user conn@Connection {connId} confId msg = do
|
||||
withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm
|
||||
withStore' $ \db -> updateConnectionStatus db conn ConnAccepted
|
||||
|
||||
agentAcceptContactAsync :: (MsgEncodingI e, ChatMonad m) => User -> Bool -> InvitationId -> ChatMsgEvent e -> m (CommandId, ConnId)
|
||||
agentAcceptContactAsync user enableNtfs invId msg = do
|
||||
agentAcceptContactAsync :: (MsgEncodingI e, ChatMonad m) => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> m (CommandId, ConnId)
|
||||
agentAcceptContactAsync user enableNtfs invId msg subMode = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact
|
||||
dm <- directMessage msg
|
||||
connId <- withAgent $ \a -> acceptContactAsync a (aCorrId cmdId) enableNtfs invId dm
|
||||
connId <- withAgent $ \a -> acceptContactAsync a (aCorrId cmdId) enableNtfs invId dm subMode
|
||||
pure (cmdId, connId)
|
||||
|
||||
deleteAgentConnectionAsync :: ChatMonad m => User -> ConnId -> m ()
|
||||
|
||||
Reference in New Issue
Block a user