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:
parent
7b582b2cf9
commit
2dff6c8859
@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: 351f42650c57f310fc1ea858ff9b7178823f1fd4
|
||||
tag: 0cabe0690beee90f460ad7bada72294222e7e109
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."351f42650c57f310fc1ea858ff9b7178823f1fd4" = "12r13yc0qk9dkii58808862wraqrk66rzmkrgyp6lg1xrazrd0d2";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."0cabe0690beee90f460ad7bada72294222e7e109" = "1yfcrifb2l59wgl14q56ywlil2g2zs57ic62s617whh3w2mnh0kz";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
|
||||
|
@ -110,6 +110,7 @@ library
|
||||
Simplex.Chat.Migrations.M20230814_indexes
|
||||
Simplex.Chat.Migrations.M20230827_file_encryption
|
||||
Simplex.Chat.Migrations.M20230829_connections_chat_vrange
|
||||
Simplex.Chat.Migrations.M20230903_connections_to_subscribe
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
@ -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 ()
|
||||
|
@ -62,7 +62,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, UserProtocol, XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
@ -176,6 +176,7 @@ data ChatController = ChatController
|
||||
outputQ :: TBQueue (Maybe CorrId, ChatResponse),
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
subscriptionMode :: TVar SubscriptionMode,
|
||||
chatLock :: Lock,
|
||||
sndFiles :: TVar (Map Int64 Handle),
|
||||
rcvFiles :: TVar (Map Int64 Handle),
|
||||
@ -960,6 +961,14 @@ type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
|
||||
|
||||
type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
|
||||
|
||||
chatReadVar :: ChatMonad' m => (ChatController -> TVar a) -> m a
|
||||
chatReadVar f = asks f >>= readTVarIO
|
||||
{-# INLINE chatReadVar #-}
|
||||
|
||||
chatWriteVar :: ChatMonad' m => (ChatController -> TVar a) -> a -> m ()
|
||||
chatWriteVar f value = asks f >>= atomically . (`writeTVar` value)
|
||||
{-# INLINE chatWriteVar #-}
|
||||
|
||||
tryChatError :: ChatMonad m => m a -> m (Either ChatError a)
|
||||
tryChatError = tryAllErrors mkChatError
|
||||
{-# INLINE tryChatError #-}
|
||||
|
@ -0,0 +1,20 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20230903_connections_to_subscribe where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20230903_connections_to_subscribe :: Query
|
||||
m20230903_connections_to_subscribe =
|
||||
[sql|
|
||||
ALTER TABLE connections ADD COLUMN to_subscribe INTEGER DEFAULT 0 NOT NULL;
|
||||
CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe);
|
||||
|]
|
||||
|
||||
down_m20230903_connections_to_subscribe :: Query
|
||||
down_m20230903_connections_to_subscribe =
|
||||
[sql|
|
||||
DROP INDEX idx_connections_to_subscribe;
|
||||
ALTER TABLE connections DROP COLUMN to_subscribe;
|
||||
|]
|
@ -287,6 +287,7 @@ CREATE TABLE connections(
|
||||
auth_err_counter INTEGER DEFAULT 0 CHECK(auth_err_counter NOT NULL),
|
||||
peer_chat_min_version INTEGER NOT NULL DEFAULT 1,
|
||||
peer_chat_max_version INTEGER NOT NULL DEFAULT 1,
|
||||
to_subscribe INTEGER DEFAULT 0 NOT NULL,
|
||||
FOREIGN KEY(snd_file_id, connection_id)
|
||||
REFERENCES snd_files(file_id, connection_id)
|
||||
ON DELETE CASCADE
|
||||
@ -711,3 +712,4 @@ CREATE INDEX idx_chat_items_user_id_item_status ON chat_items(
|
||||
user_id,
|
||||
item_status
|
||||
);
|
||||
CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe);
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@ -6,25 +7,30 @@
|
||||
|
||||
module Simplex.Chat.Store.Connections
|
||||
( getConnectionEntity,
|
||||
getConnectionsToSubscribe,
|
||||
unsetConnectionToSubscribe,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad.Except
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime (..))
|
||||
import Database.SQLite.Simple ((:.) (..))
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Store.Files
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow')
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
|
||||
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
@ -142,3 +148,17 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact
|
||||
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
|
||||
userContact_ _ = Left SEUserContactLinkNotFound
|
||||
|
||||
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
|
||||
getConnectionsToSubscribe db = do
|
||||
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
|
||||
entities <- forM aConnIds $ \acId -> do
|
||||
getUserByAConnId db acId >>= \case
|
||||
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId)
|
||||
Nothing -> pure Nothing
|
||||
unsetConnectionToSubscribe db
|
||||
let connIds = map (\(AgentConnId connId) -> connId) aConnIds
|
||||
pure (connIds, catMaybes entities)
|
||||
|
||||
unsetConnectionToSubscribe :: DB.Connection -> IO ()
|
||||
unsetConnectionToSubscribe db = DB.execute_ db "UPDATE connections SET to_subscribe = 0 WHERE to_subscribe = 1"
|
||||
|
@ -75,6 +75,7 @@ import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||
import Simplex.Messaging.Version
|
||||
|
||||
getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection
|
||||
@ -109,8 +110,8 @@ deletePendingContactConnection db userId connId =
|
||||
|]
|
||||
(userId, connId, ConnContact)
|
||||
|
||||
createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection
|
||||
createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do
|
||||
createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> SubscriptionMode -> IO PendingContactConnection
|
||||
createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId subMode = do
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile
|
||||
let pccConnStatus = ConnJoined
|
||||
@ -119,10 +120,10 @@ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile grou
|
||||
[sql|
|
||||
INSERT INTO connections (
|
||||
user_id, agent_conn_id, conn_status, conn_type,
|
||||
via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at, to_subscribe
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt))
|
||||
((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt, subMode == SMOnlyCreate))
|
||||
pccConnId <- insertedRowId db
|
||||
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt}
|
||||
|
||||
@ -162,17 +163,17 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do
|
||||
"SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1"
|
||||
(userId, cReqHash)
|
||||
|
||||
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection
|
||||
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do
|
||||
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> SubscriptionMode -> IO PendingContactConnection
|
||||
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile subMode = do
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections
|
||||
(user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)
|
||||
(user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at, to_subscribe) VALUES (?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt)
|
||||
(userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt, subMode == SMOnlyCreate)
|
||||
pccConnId <- insertedRowId db
|
||||
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt}
|
||||
|
||||
@ -587,8 +588,8 @@ deleteContactRequest db User {userId} contactRequestId = do
|
||||
(userId, userId, contactRequestId)
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId)
|
||||
|
||||
createAcceptedContact :: DB.Connection -> User -> ConnId -> VersionRange -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact
|
||||
createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId cReqChatVRange localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do
|
||||
createAcceptedContact :: DB.Connection -> User -> ConnId -> VersionRange -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> SubscriptionMode -> IO Contact
|
||||
createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId cReqChatVRange localDisplayName profileId profile userContactLinkId xContactId incognitoProfile subMode = do
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- forM incognitoProfile $ \case
|
||||
@ -600,7 +601,7 @@ createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}
|
||||
"INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)"
|
||||
(userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId)
|
||||
contactId <- insertedRowId db
|
||||
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt
|
||||
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt}
|
||||
|
||||
@ -616,7 +617,7 @@ getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO C
|
||||
getContact_ db user@User {userId} contactId deleted =
|
||||
ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $
|
||||
DB.query
|
||||
db
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
|
@ -100,6 +100,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||
|
||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||
getLiveSndFileTransfers db User {userId} = do
|
||||
@ -156,8 +157,8 @@ getPendingSndChunks db fileId connId =
|
||||
|]
|
||||
(fileId, connId)
|
||||
|
||||
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta
|
||||
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do
|
||||
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> SubscriptionMode -> IO FileTransferMeta
|
||||
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize subMode = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
@ -165,7 +166,7 @@ createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitatio
|
||||
((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs))
|
||||
fileId <- insertedRowId db
|
||||
forM_ acId_ $ \acId -> do
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId acId
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode
|
||||
let fileStatus = FSNew
|
||||
DB.execute
|
||||
db
|
||||
@ -173,10 +174,10 @@ createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitatio
|
||||
(fileId, fileStatus, fileInline, connId, currentTs, currentTs)
|
||||
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
|
||||
|
||||
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO ()
|
||||
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
|
||||
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> SubscriptionMode -> IO ()
|
||||
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) subMode = do
|
||||
currentTs <- getCurrentTime
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId acId
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode
|
||||
setCommandConnId db user cmdId connId
|
||||
DB.execute
|
||||
db
|
||||
@ -193,10 +194,10 @@ createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation
|
||||
fileId <- insertedRowId db
|
||||
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
|
||||
|
||||
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO ()
|
||||
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do
|
||||
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> SubscriptionMode -> IO ()
|
||||
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} subMode = do
|
||||
currentTs <- getCurrentTime
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId acId
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode
|
||||
setCommandConnId db user cmdId connId
|
||||
DB.execute
|
||||
db
|
||||
@ -422,10 +423,10 @@ getChatRefByFileId db User {userId} fileId =
|
||||
|]
|
||||
(userId, fileId)
|
||||
|
||||
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
|
||||
createSndFileConnection_ db userId fileId agentConnId = do
|
||||
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> SubscriptionMode -> IO Connection
|
||||
createSndFileConnection_ db userId fileId agentConnId subMode = do
|
||||
currentTs <- getCurrentTime
|
||||
createConnection_ db userId ConnSndFile (Just fileId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs
|
||||
createConnection_ db userId ConnSndFile (Just fileId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode
|
||||
|
||||
updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO ()
|
||||
updateSndFileStatus db SndFileTransfer {fileId, connId} status = do
|
||||
@ -644,14 +645,14 @@ getRcvFileTransfer db User {userId} fileId = do
|
||||
_ -> pure Nothing
|
||||
cancelled = fromMaybe False cancelled_
|
||||
|
||||
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do
|
||||
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
|
||||
currentTs <- getCurrentTime
|
||||
acceptRcvFT_ db user fileId filePath Nothing currentTs
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
||||
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
|
||||
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at, to_subscribe) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
|
||||
connId <- insertedRowId db
|
||||
setCommandConnId db user cmdId connId
|
||||
runExceptT $ getChatItemByFileId db user fileId
|
||||
|
@ -105,6 +105,7 @@ import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode)
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
import Simplex.Messaging.Version
|
||||
import UnliftIO.STM
|
||||
@ -135,8 +136,8 @@ toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just member
|
||||
Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
|
||||
toMaybeGroupMember _ _ = Nothing
|
||||
|
||||
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO ()
|
||||
createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole =
|
||||
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO ()
|
||||
createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole subMode =
|
||||
checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
@ -144,7 +145,7 @@ createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName}
|
||||
"INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
||||
(userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs)
|
||||
userContactLinkId <- insertedRowId db
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode
|
||||
|
||||
getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection
|
||||
getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} =
|
||||
@ -536,7 +537,7 @@ groupMemberQuery =
|
||||
LEFT JOIN connections c ON c.connection_id = (
|
||||
SELECT max(cc.connection_id)
|
||||
FROM connections cc
|
||||
where cc.user_id = ? AND cc.group_member_id = m.group_member_id
|
||||
WHERE cc.user_id = ? AND cc.group_member_id = m.group_member_id
|
||||
)
|
||||
|]
|
||||
|
||||
@ -614,12 +615,12 @@ getGroupInvitation db user groupId =
|
||||
firstRow fromOnly (SEGroupNotFound groupId) $
|
||||
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId)
|
||||
|
||||
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember
|
||||
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Connection {peerChatVRange}} memberRole agentConnId connRequest =
|
||||
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember
|
||||
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Connection {peerChatVRange}} memberRole agentConnId connRequest subMode =
|
||||
createWithRandomId gVar $ \memId -> do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt subMode
|
||||
pure member
|
||||
where
|
||||
createMember_ memberId createdAt = do
|
||||
@ -654,13 +655,13 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
|
||||
:. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt)
|
||||
)
|
||||
|
||||
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> ExceptT StoreError IO ()
|
||||
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) peerChatVRange =
|
||||
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> SubscriptionMode -> ExceptT StoreError IO ()
|
||||
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) peerChatVRange subMode =
|
||||
createWithRandomId gVar $ \memId -> do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
insertMember_ (MemberId memId) createdAt
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt subMode
|
||||
setCommandConnId db user cmdId connId
|
||||
where
|
||||
insertMember_ memberId createdAt =
|
||||
@ -713,15 +714,15 @@ getMemberInvitation db User {userId} groupMemberId =
|
||||
fmap join . maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId)
|
||||
|
||||
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> VersionRange -> IO ()
|
||||
createMemberConnection db userId GroupMember {groupMemberId} agentConnId peerChatVRange = do
|
||||
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> VersionRange -> SubscriptionMode -> IO ()
|
||||
createMemberConnection db userId GroupMember {groupMemberId} agentConnId peerChatVRange subMode = do
|
||||
currentTs <- getCurrentTime
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 currentTs
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 currentTs subMode
|
||||
|
||||
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionRange -> IO ()
|
||||
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) peerChatVRange = do
|
||||
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionRange -> SubscriptionMode -> IO ()
|
||||
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) peerChatVRange subMode = do
|
||||
currentTs <- getCurrentTime
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 currentTs
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 currentTs subMode
|
||||
setCommandConnId db user cmdId connId
|
||||
|
||||
updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
|
||||
@ -920,14 +921,14 @@ getIntroduction_ db reMember toMember = ExceptT $ do
|
||||
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
|
||||
toIntro _ = Left SEIntroNotFound
|
||||
|
||||
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
|
||||
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
|
||||
let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
|
||||
cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
currentTs <- liftIO getCurrentTime
|
||||
newMember <- case directConnIds of
|
||||
Just (directCmdId, directAgentConnId) -> do
|
||||
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs
|
||||
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs subMode
|
||||
liftIO $ setCommandConnId db user directCmdId directConnId
|
||||
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
|
||||
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Just contactId, memProfileId}
|
||||
@ -936,18 +937,18 @@ createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupM
|
||||
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Nothing, memProfileId}
|
||||
liftIO $ do
|
||||
member <- createNewMember_ db user gInfo newMember currentTs
|
||||
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs
|
||||
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs subMode
|
||||
liftIO $ setCommandConnId db user groupCmdId groupConnId
|
||||
pure (member :: GroupMember) {activeConn = Just conn}
|
||||
|
||||
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> IO ()
|
||||
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
|
||||
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO ()
|
||||
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
|
||||
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
currentTs <- getCurrentTime
|
||||
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs
|
||||
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs subMode
|
||||
setCommandConnId db user groupCmdId groupConnId
|
||||
forM_ directConnIds $ \(directCmdId, directAgentConnId) -> do
|
||||
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId mcvr viaContactId Nothing customUserProfileId cLevel currentTs
|
||||
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId mcvr viaContactId Nothing customUserProfileId cLevel currentTs subMode
|
||||
setCommandConnId db user directCmdId directConnId
|
||||
contactId <- createMemberContact_ directConnId currentTs
|
||||
updateMember_ contactId currentTs
|
||||
@ -977,7 +978,7 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
|
||||
|]
|
||||
[":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId]
|
||||
|
||||
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> IO Connection
|
||||
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection
|
||||
createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId peerChatVRange viaContact Nothing Nothing
|
||||
|
||||
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
|
||||
|
@ -78,6 +78,7 @@ import Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
||||
import Simplex.Chat.Migrations.M20230814_indexes
|
||||
import Simplex.Chat.Migrations.M20230827_file_encryption
|
||||
import Simplex.Chat.Migrations.M20230829_connections_chat_vrange
|
||||
import Simplex.Chat.Migrations.M20230903_connections_to_subscribe
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@ -155,7 +156,8 @@ schemaMigrations =
|
||||
("20230721_group_snd_item_statuses", m20230721_group_snd_item_statuses, Just down_m20230721_group_snd_item_statuses),
|
||||
("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
|
||||
("20230827_file_encryption", m20230827_file_encryption, Just down_m20230827_file_encryption),
|
||||
("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange)
|
||||
("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange),
|
||||
("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
@ -80,7 +80,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..))
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
|
||||
@ -293,8 +293,8 @@ getUserContactProfiles db User {userId} =
|
||||
toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile)
|
||||
toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences}
|
||||
|
||||
createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
|
||||
createUserContactLink db User {userId} agentConnId cReq =
|
||||
createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> SubscriptionMode -> ExceptT StoreError IO ()
|
||||
createUserContactLink db User {userId} agentConnId cReq subMode =
|
||||
checkConstraint SEDuplicateContactLink . liftIO $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
@ -302,7 +302,7 @@ createUserContactLink db User {userId} agentConnId cReq =
|
||||
"INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)"
|
||||
(userId, cReq, currentTs, currentTs)
|
||||
userContactLinkId <- insertedRowId db
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode
|
||||
|
||||
getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection]
|
||||
getUserAddressConnections db User {userId} = do
|
||||
|
@ -36,6 +36,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||
import Simplex.Messaging.Util (allFinally)
|
||||
import Simplex.Messaging.Version
|
||||
import UnliftIO.STM
|
||||
@ -158,8 +159,8 @@ toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, v
|
||||
Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter, minVer, maxVer))
|
||||
toMaybeConnection _ = Nothing
|
||||
|
||||
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> VersionRange -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection
|
||||
createConnection_ db userId connType entityId acId peerChatVRange@(VersionRange minV maxV) viaContact viaUserContactLink customUserProfileId connLevel currentTs = do
|
||||
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> VersionRange -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> IO Connection
|
||||
createConnection_ db userId connType entityId acId peerChatVRange@(VersionRange minV maxV) viaContact viaUserContactLink customUserProfileId connLevel currentTs subMode = do
|
||||
viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId ->
|
||||
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId)
|
||||
let viaGroupLink = isJust viaLinkGroupId
|
||||
@ -169,12 +170,12 @@ createConnection_ db userId connType entityId acId peerChatVRange@(VersionRange
|
||||
INSERT INTO connections (
|
||||
user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type,
|
||||
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at,
|
||||
peer_chat_min_version, peer_chat_max_version
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
peer_chat_min_version, peer_chat_max_version, to_subscribe
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType)
|
||||
:. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs)
|
||||
:. (minV, maxV)
|
||||
:. (minV, maxV, subMode == SMOnlyCreate)
|
||||
)
|
||||
connId <- insertedRowId db
|
||||
pure Connection {connId, agentConnId = AgentConnId acId, peerChatVRange, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0}
|
||||
|
@ -49,7 +49,7 @@ extra-deps:
|
||||
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: 351f42650c57f310fc1ea858ff9b7178823f1fd4
|
||||
commit: 0cabe0690beee90f460ad7bada72294222e7e109
|
||||
- github: kazu-yamamoto/http2
|
||||
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
|
||||
# - ../direct-sqlcipher
|
||||
|
@ -57,6 +57,8 @@ chatDirectTests = do
|
||||
it "start/stop/export/import chat" testMaintenanceMode
|
||||
it "export/import chat with files" testMaintenanceModeWithFiles
|
||||
it "encrypt/decrypt database" testDatabaseEncryption
|
||||
describe "coordination between app and NSE" $ do
|
||||
it "should not subscribe in NSE and subscribe in the app" testSubscribeAppNSE
|
||||
describe "mute/unmute messages" $ do
|
||||
it "mute/unmute contact" testMuteContact
|
||||
it "mute/unmute group" testMuteGroup
|
||||
@ -970,6 +972,35 @@ testDatabaseEncryption tmp = do
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
testChatWorking alice bob
|
||||
|
||||
testSubscribeAppNSE :: HasCallStack => FilePath -> IO ()
|
||||
testSubscribeAppNSE tmp =
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
withTestChatOpts tmp testOpts {maintenance = True} "alice" $ \nseAlice -> do
|
||||
alice ##> "/_app suspend 1"
|
||||
alice <## "ok"
|
||||
alice <## "chat suspended"
|
||||
nseAlice ##> "/_start subscribe=off expire=off xftp=off"
|
||||
nseAlice <## "chat started"
|
||||
nseAlice ##> "/ad"
|
||||
cLink <- getContactLink nseAlice True
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "connection request sent!"
|
||||
(nseAlice </)
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice <## "Your address is active! To show: /sa"
|
||||
alice <## "bob (Bob) wants to connect to you!"
|
||||
alice <## "to accept: /ac bob"
|
||||
alice <## "to reject: /rc bob (the sender will NOT be notified)"
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
threadDelay 100000
|
||||
alice <##> bob
|
||||
|
||||
testMuteContact :: HasCallStack => FilePath -> IO ()
|
||||
testMuteContact =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
|
Loading…
Reference in New Issue
Block a user