From f4ad3a983e06a694917decb4283dfee0f3d3dae7 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 11 Jan 2023 13:47:20 +0000 Subject: [PATCH 01/19] support users in agent to isolate traffic of different users (#598) * users table, isolate traffic sessions by users or by queues * remove extra indices * corrections Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- apps/smp-agent/Main.hs | 3 +- cabal.project | 6 + simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 182 +++++++------ src/Simplex/Messaging/Agent/Client.hs | 250 +++++++++++------- src/Simplex/Messaging/Agent/Env/SQLite.hs | 4 +- src/Simplex/Messaging/Agent/Store.hs | 33 ++- src/Simplex/Messaging/Agent/Store/SQLite.hs | 54 ++-- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../SQLite/Migrations/M20230110_users.hs | 27 ++ .../Store/SQLite/Migrations/agent_schema.sql | 6 +- src/Simplex/Messaging/Client.hs | 20 +- src/Simplex/Messaging/Client/Agent.hs | 2 +- src/Simplex/Messaging/Protocol.hs | 1 + src/Simplex/Messaging/Transport/Client.hs | 16 +- .../Messaging/Transport/HTTP2/Client.hs | 2 +- tests/AgentTests/FunctionalAPITests.hs | 56 ++-- tests/AgentTests/NotificationTests.hs | 16 +- tests/AgentTests/SQLiteTests.hs | 14 +- tests/NtfClient.hs | 2 +- tests/SMPAgentClient.hs | 16 +- tests/SMPClient.hs | 2 +- 22 files changed, 459 insertions(+), 258 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs diff --git a/apps/smp-agent/Main.hs b/apps/smp-agent/Main.hs index da43bdec7..0c51b5619 100644 --- a/apps/smp-agent/Main.hs +++ b/apps/smp-agent/Main.hs @@ -7,6 +7,7 @@ module Main where import Control.Logger.Simple import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Server (runSMPAgent) import Simplex.Messaging.Client (defaultNetworkConfig) @@ -18,7 +19,7 @@ cfg = defaultAgentConfig servers :: InitialAgentServers servers = InitialAgentServers - { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"], + { smp = M.fromList [(1, L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"])], ntf = [], netCfg = defaultNetworkConfig } diff --git a/cabal.project b/cabal.project index 96cf5badd..020cc61f7 100644 --- a/cabal.project +++ b/cabal.project @@ -1,11 +1,17 @@ packages: . -- packages: . ../direct-sqlcipher ../sqlcipher-simple +-- packages: . ../hs-socks source-repository-package type: git location: https://github.com/simplex-chat/aeson.git tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7 +source-repository-package + type: git + location: https://github.com/simplex-chat/hs-socks.git + tag: a30cc7a79a08d8108316094f8f2f82a0c5e1ac51 + source-repository-package type: git location: https://github.com/simplex-chat/direct-sqlcipher.git diff --git a/simplexmq.cabal b/simplexmq.cabal index a2c25d487..b5a6e4549 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -55,6 +55,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 444a9a63b..042c25ab9 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -38,6 +38,8 @@ module Simplex.Messaging.Agent disconnectAgentClient, resumeAgentClient, withConnLock, + createUser, + deleteUser, createConnectionAsync, joinConnectionAsync, allowConnectionAsync, @@ -158,13 +160,19 @@ resumeAgentClient c = atomically $ writeTVar (active c) True -- | type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m) +createUser :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId +createUser c = withAgentEnv c . createUser' c + +deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> m () +deleteUser c = withAgentEnv c . deleteUser' c + -- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id -createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> ACorrId -> Bool -> SConnectionMode c -> m ConnId -createConnectionAsync c corrId enableNtfs cMode = withAgentEnv c $ newConnAsync c corrId enableNtfs cMode +createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId +createConnectionAsync c userId corrId enableNtfs cMode = withAgentEnv c $ newConnAsync c userId corrId enableNtfs cMode -- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id -joinConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConnectionAsync c corrId enableNtfs = withAgentEnv c .: joinConnAsync c corrId enableNtfs +joinConnectionAsync :: AgentErrorMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId +joinConnectionAsync c userId corrId enableNtfs = withAgentEnv c .: joinConnAsync c userId corrId enableNtfs -- | Allow connection to continue after CONF notification (LET command), no synchronous response allowConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> m () @@ -187,12 +195,12 @@ deleteConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId - deleteConnectionAsync c = withAgentEnv c .: deleteConnectionAsync' c -- | Create SMP agent connection (NEW command) -createConnection :: AgentErrorMonad m => AgentClient -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) -createConnection c enableNtfs cMode clientData = withAgentEnv c $ newConn c "" False enableNtfs cMode clientData +createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) +createConnection c userId enableNtfs cMode clientData = withAgentEnv c $ newConn c userId "" False enableNtfs cMode clientData -- | Join SMP agent connection (JOIN command) -joinConnection :: AgentErrorMonad m => AgentClient -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConnection c enableNtfs = withAgentEnv c .: joinConn c "" False enableNtfs +joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId +joinConnection c userId enableNtfs = withAgentEnv c .: joinConn c userId "" False enableNtfs -- | Allow connection to continue after CONF notification (LET command) allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m () @@ -256,12 +264,12 @@ getConnectionRatchetAdHash :: AgentErrorMonad m => AgentClient -> ConnId -> m By getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c -- | Change servers to be used for creating new queues -setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m () -setSMPServers c = withAgentEnv c . setSMPServers' c +setSMPServers :: AgentErrorMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m () +setSMPServers c = withAgentEnv c .: setSMPServers' c -- | Test SMP server -testSMPServerConnection :: AgentErrorMonad m => AgentClient -> SMPServerWithAuth -> m (Maybe SMPTestFailure) -testSMPServerConnection c = withAgentEnv c . runSMPServerTest c +testSMPServerConnection :: AgentErrorMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure) +testSMPServerConnection c = withAgentEnv c .: runSMPServerTest c setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m () setNtfServers c = withAgentEnv c . setNtfServers' c @@ -349,8 +357,8 @@ client c@AgentClient {rcvQ, subQ} = forever $ do -- | execute any SMP agent command processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent) processCommand c (connId, cmd) = case cmd of - NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c connId False enableNtfs cMode Nothing - JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c connId False enableNtfs cReq connInfo + NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId False enableNtfs cMode Nothing + JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK) ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo RJCT invId -> rejectContact' c connId invId $> (connId, OK) @@ -361,29 +369,43 @@ processCommand c (connId, cmd) = case cmd of OFF -> suspendConnection' c connId $> (connId, OK) DEL -> deleteConnection' c connId $> (connId, OK) CHK -> (connId,) . STAT <$> getConnectionServers' c connId + where + -- command interface does not support different users + userId = 1 -newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> ACorrId -> Bool -> SConnectionMode c -> m ConnId -newConnAsync c corrId enableNtfs cMode = do +createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId +createUser' c srvs = do + userId <- withStore' c createUserRecord + atomically $ TM.insert userId srvs $ smpServers c + pure userId + +deleteUser' :: AgentMonad m => AgentClient -> UserId -> m () +deleteUser' c userId = do + withStore c (`deleteUserRecord` userId) + atomically $ TM.delete userId $ smpServers c + +newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId +newConnAsync c userId corrId enableNtfs cMode = do g <- asks idsDrg connAgentVersion <- asks $ maxVersion . smpAgentVRange . config - let cData = ConnData {connId = "", connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent + let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent connId <- withStore c $ \db -> createNewConn db g cData cMode enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pure connId -joinConnAsync :: AgentMonad m => AgentClient -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConnAsync c corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo = do +joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId +joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo = do aVRange <- asks $ smpAgentVRange . config case crAgentVRange `compatibleVersion` aVRange of Just (Compatible connAgentVersion) -> do g <- asks idsDrg let duplexHS = connAgentVersion /= 1 - cData = ConnData {connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False} + cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False} connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo pure connId _ -> throwError $ AGENT A_VERSION -joinConnAsync _c _corrId _enableNtfs (CRContactUri _) _cInfo = +joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _cInfo = throwError $ CMD PROHIBITED allowConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> m () @@ -397,9 +419,9 @@ acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> Invitat acceptContactAsync' c corrId enableNtfs invId ownConnInfo = do Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId) withStore c (`getConn` contactConnId) >>= \case - SomeConn _ ContactConnection {} -> do + SomeConn _ (ContactConnection ConnData {userId} _) -> do withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConnAsync c corrId enableNtfs connReq ownConnInfo `catchError` \err -> do + joinConnAsync c userId corrId enableNtfs connReq ownConnInfo `catchError` \err -> do withStore' c (`unacceptInvitation` invId) throwError err _ -> throwError $ CMD PROHIBITED @@ -444,14 +466,14 @@ switchConnectionAsync' c corrId connId = SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand SWCH _ -> throwError $ CMD PROHIBITED -newConn :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) -newConn c connId asyncMode enableNtfs cMode clientData = - getSMPServer c >>= newConnSrv c connId asyncMode enableNtfs cMode clientData +newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) +newConn c userId connId asyncMode enableNtfs cMode clientData = + getSMPServer c userId >>= newConnSrv c userId connId asyncMode enableNtfs cMode clientData -newConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) -newConnSrv c connId asyncMode enableNtfs cMode clientData srv = do +newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) +newConnSrv c userId connId asyncMode enableNtfs cMode clientData srv = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - (q, qUri) <- newRcvQueue c "" srv smpClientVRange + (q, qUri) <- newRcvQueue c userId "" srv smpClientVRange connId' <- setUpConn asyncMode q $ maxVersion smpAgentVRange let rq = (q :: RcvQueue) {connId = connId'} addSubscription c rq @@ -471,19 +493,19 @@ newConnSrv c connId asyncMode enableNtfs cMode clientData srv = do pure connId setUpConn False rq connAgentVersion = do g <- asks idsDrg - let cData = ConnData {connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent withStore c $ \db -> createRcvConn db g cData rq cMode -joinConn :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConn c connId asyncMode enableNtfs cReq cInfo = do +joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId +joinConn c userId connId asyncMode enableNtfs cReq cInfo = do srv <- case cReq of CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> - getNextSMPServer c [qServer q] - _ -> getSMPServer c - joinConnSrv c connId asyncMode enableNtfs cReq cInfo srv + getNextSMPServer c userId [qServer q] + _ -> getSMPServer c userId + joinConnSrv c userId connId asyncMode enableNtfs cReq cInfo srv -joinConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServerWithAuth -> m ConnId -joinConnSrv c connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) cInfo srv = do +joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServerWithAuth -> m ConnId +joinConnSrv c userId connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) cInfo srv = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config case ( qUri `compatibleVersion` smpClientVRange, e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange, @@ -493,9 +515,9 @@ joinConnSrv c connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData {crAge (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams (_, rcDHRs) <- liftIO C.generateKeyPair' let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams - q <- newSndQueue "" qInfo + q <- newSndQueue userId "" qInfo let duplexHS = connAgentVersion /= 1 - cData = ConnData {connId, connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False} + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False} connId' <- setUpConn asyncMode cData q rc let sq = (q :: SndQueue) {connId = connId'} cData' = (cData :: ConnData) {connId = connId'} @@ -520,23 +542,23 @@ joinConnSrv c connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData {crAge liftIO $ createRatchet db connId' rc pure connId' _ -> throwError $ AGENT A_VERSION -joinConnSrv c connId False enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo srv = do +joinConnSrv c userId connId False enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo srv = do aVRange <- asks $ smpAgentVRange . config clientVRange <- asks $ smpClientVRange . config case ( qUri `compatibleVersion` clientVRange, crAgentVRange `compatibleVersion` aVRange ) of (Just qInfo, Just vrsn) -> do - (connId', cReq) <- newConnSrv c connId False enableNtfs SCMInvitation Nothing srv - sendInvitation c qInfo vrsn cReq cInfo + (connId', cReq) <- newConnSrv c userId connId False enableNtfs SCMInvitation Nothing srv + sendInvitation c userId qInfo vrsn cReq cInfo pure connId' _ -> throwError $ AGENT A_VERSION -joinConnSrv _c _connId True _enableNtfs (CRContactUri _) _cInfo _srv = do +joinConnSrv _c _userId _connId True _enableNtfs (CRContactUri _) _cInfo _srv = do throwError $ CMD PROHIBITED createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> m SMPQueueInfo -createReplyQueue c ConnData {connId, enableNtfs} SndQueue {smpClientVersion} srv = do - (rq, qUri) <- newRcvQueue c connId srv $ versionToRange smpClientVersion +createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} srv = do + (rq, qUri) <- newRcvQueue c userId connId srv $ versionToRange smpClientVersion let qInfo = toVersionT qUri smpClientVersion addSubscription c rq void . withStore c $ \db -> upgradeSndConnToDuplex db connId rq @@ -564,9 +586,9 @@ acceptContact' :: AgentMonad m => AgentClient -> ConnId -> Bool -> InvitationId acceptContact' c connId enableNtfs invId ownConnInfo = withConnLock c connId "acceptContact" $ do Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId) withStore c (`getConn` contactConnId) >>= \case - SomeConn _ ContactConnection {} -> do + SomeConn _ (ContactConnection ConnData {userId} _) -> do withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConn c connId False enableNtfs connReq ownConnInfo `catchError` \err -> do + joinConn c userId connId False enableNtfs connReq ownConnInfo `catchError` \err -> do withStore' c (`unacceptInvitation` invId) throwError err _ -> throwError $ CMD PROHIBITED @@ -799,13 +821,15 @@ runCommandProcessing c@AgentClient {subQ} server_ = do NEW enableNtfs (ACM cMode) -> noServer $ do usedSrvs <- newTVarIO ([] :: [SMPServer]) tryCommand . withNextSrv usedSrvs [] $ \srv -> do - (_, cReq) <- newConnSrv c connId True enableNtfs cMode Nothing srv + let userId = 1 -- TODO + (_, cReq) <- newConnSrv c userId connId True enableNtfs cMode Nothing srv notify $ INV (ACR cMode cReq) JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) connInfo -> noServer $ do let initUsed = [qServer q] usedSrvs <- newTVarIO initUsed tryCommand . withNextSrv usedSrvs initUsed $ \srv -> do - void $ joinConnSrv c connId True enableNtfs cReq connInfo srv + let userId = 1 -- TODO + void $ joinConnSrv c userId connId True enableNtfs cReq connInfo srv notify OK LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId -> withServer' . tryCommand $ ackMessage' c connId msgId >> notify OK @@ -901,10 +925,12 @@ runCommandProcessing c@AgentClient {subQ} server_ = do withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m () withNextSrv usedSrvs initUsed action = do used <- readTVarIO usedSrvs - srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c used + let userId = 1 -- TODO + srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId used atomically $ do - srvs <- readTVar $ smpServers c - let used' = if length used + 1 >= L.length srvs then initUsed else srv : used + srvs_ <- TM.lookup userId $ smpServers c + -- TODO this condition does not account for servers change, it has to be changed to see if there are any remaining unused servers configured for the user + let used' = if length used + 1 >= maybe 0 L.length srvs_ then initUsed else srv : used writeTVar usedSrvs used' action srvAuth -- ^ ^ ^ async command processing / @@ -978,7 +1004,7 @@ getPendingMsgQ c SndQueue {server, sndId} = do pure q runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m () -runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandshake} sq = do +runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, duplexHandshake} sq = do (mq, qLock) <- atomically $ getPendingMsgQ c sq ri <- asks $ messageRetryInterval . config forever $ do @@ -1067,7 +1093,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh -- and this branch should never be reached as receive is created before the confirmation, -- so the condition is not necessary here, strictly speaking. _ -> unless (duplexHandshake == Just True) $ do - srv <- getSMPServer c + srv <- getSMPServer c userId qInfo <- createReplyQueue c cData sq srv void . enqueueMessage c cData sq SMP.noMsgFlags $ REPLY [qInfo] AM_A_MSG_ -> notify $ SENT mId @@ -1142,12 +1168,12 @@ switchConnection' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats switchConnection' c connId = withConnLock c connId "switchConnection" $ do SomeConn _ conn <- withStore c (`getConn` connId) case conn of - DuplexConnection cData rqs@(rq@RcvQueue {server, dbQueueId, sndId} :| rqs_) sqs -> do + DuplexConnection cData@ConnData {userId} rqs@(rq@RcvQueue {server, dbQueueId, sndId} :| rqs_) sqs -> do clientVRange <- asks $ smpClientVRange . config -- try to get the server that is different from all queues, or at least from the primary rcv queue - srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) - srv' <- if srv == server then getNextSMPServer c [server] else pure srvAuth - (q, qUri) <- newRcvQueue c connId srv' clientVRange + srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) + srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth + (q, qUri) <- newRcvQueue c userId connId srv' clientVRange let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} void . withStore c $ \db -> addConnRcvQueue db connId rq' addSubscription c rq' @@ -1217,8 +1243,8 @@ connectionStats = \case NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []} -- | Change servers to be used for creating new queues, in Reader monad -setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m () -setSMPServers' c = atomically . writeTVar (smpServers c) +setSMPServers' :: AgentMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m () +setSMPServers' c userId srvs = atomically $ TM.insert userId srvs $ smpServers c registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus registerNtfToken' c suppliedDeviceToken suppliedNtfMode = @@ -1457,8 +1483,8 @@ debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs} = do where getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls) -getSMPServer :: AgentMonad m => AgentClient -> m SMPServerWithAuth -getSMPServer c = readTVarIO (smpServers c) >>= pickServer +getSMPServer :: AgentMonad m => AgentClient -> UserId -> m SMPServerWithAuth +getSMPServer c userId = withUserServers c userId pickServer pickServer :: AgentMonad m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth pickServer = \case @@ -1467,13 +1493,18 @@ pickServer = \case gen <- asks randomServer atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1)) -getNextSMPServer :: AgentMonad m => AgentClient -> [SMPServer] -> m SMPServerWithAuth -getNextSMPServer c usedSrvs = do - srvs <- readTVarIO $ smpServers c +getNextSMPServer :: AgentMonad m => AgentClient -> UserId -> [SMPServer] -> m SMPServerWithAuth +getNextSMPServer c userId usedSrvs = withUserServers c userId $ \srvs -> case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of Just srvs' -> pickServer srvs' _ -> pickServer srvs +withUserServers :: AgentMonad m => AgentClient -> UserId -> (NonEmpty SMPServerWithAuth -> m a) -> m a +withUserServers c userId action = + atomically (TM.lookup userId $ smpServers c) >>= \case + Just srvs -> action srvs + _ -> throwError $ INTERNAL "unknown userId - no SMP servers" + subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () subscriber c@AgentClient {msgQ} = forever $ do t <- atomically $ readTBQueue msgQ @@ -1488,7 +1519,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm processSMP rq conn $ connData conn where processSMP :: RcvQueue -> Connection c -> ConnData -> m () - processSMP rq@RcvQueue {e2ePrivKey, e2eDhSecret, status} conn cData@ConnData {connId, duplexHandshake} = withConnLock c connId "processSMP" $ + processSMP rq@RcvQueue {e2ePrivKey, e2eDhSecret, status} conn cData@ConnData {userId, connId, duplexHandshake} = withConnLock c connId "processSMP" $ case cmd of SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> handleNotifyAck $ @@ -1586,8 +1617,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm ackDel = enqueueCmd . ICAckDel rId srvMsgId handleNotifyAck :: m () -> m () handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack - SMP.END -> - atomically (TM.lookup srv smpClients $>>= tryReadTMVar >>= processEND) + SMP.END -> do + -- TODO is race condition possible here on session mode change? + tSess <- mkSMPTransportSession c rq + atomically (TM.lookup tSess smpClients $>>= tryReadTMVar >>= processEND) >>= logServer "<--" c srv rId where processEND = \case @@ -1724,7 +1757,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm case (findQ (qAddress sqInfo) sqs, findQ addr sqs) of (Just _, _) -> qError "QADD: queue address is already used in connection" (_, Just _replaced@SndQueue {dbQueueId}) -> do - sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue connId qInfo + sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue userId connId qInfo let sq' = (sq_ :: SndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} void . withStore c $ \db -> addConnSndQueue db connId sq' case (sndPublicKey, e2ePubKey) of @@ -1796,12 +1829,12 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm | otherwise = MsgError MsgDuplicate -- this case is not possible connectReplyQueues :: AgentMonad m => AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> m () -connectReplyQueues c cData@ConnData {connId} ownConnInfo (qInfo :| _) = do +connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do clientVRange <- asks $ smpClientVRange . config case qInfo `proveCompatible` clientVRange of Nothing -> throwError $ AGENT A_VERSION Just qInfo' -> do - sq <- newSndQueue connId qInfo' + sq <- newSndQueue userId connId qInfo' dbQueueId <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing @@ -1860,14 +1893,15 @@ agentRatchetDecrypt db connId encAgentMsg = do liftIO $ updateRatchet db connId rc' skippedDiff liftEither $ first (SEAgentError . cryptoError) agentMsgBody_ -newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => ConnId -> Compatible SMPQueueInfo -> m SndQueue -newSndQueue connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do +newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m SndQueue +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do C.SignAlg a <- asks $ cmdSignAlg . config (sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a (e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair' pure SndQueue - { connId, + { userId, + connId, server = smpServer, sndId = senderId, sndPublicKey = Just sndPublicKey, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 9a3642767..54c3e11ab 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -48,6 +48,9 @@ module Simplex.Messaging.Agent.Client agentNtfCreateSubscription, agentNtfCheckSubscription, agentNtfDeleteSubscription, + -- TODO possibly, this should not be exported? + -- this is used in END processing + mkSMPTransportSession, agentCbEncrypt, agentCbDecrypt, cryptoError, @@ -131,6 +134,7 @@ import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parse) import Simplex.Messaging.Protocol ( AProtocolType (..), BrokerMsg, + EntityId, ErrorType, MsgFlags (..), MsgId, @@ -166,15 +170,22 @@ type SMPClientVar = TMVar (Either AgentErrorType SMPClient) type NtfClientVar = TMVar (Either AgentErrorType NtfClient) +-- | Transport session key - includes entity ID if `sessionMode = TSMEntity`. +type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) + +type SMPTransportSession = TransportSession SMP.BrokerMsg + +type NtfTransportSession = TransportSession NtfResponse + data AgentClient = AgentClient { active :: TVar Bool, rcvQ :: TBQueue (ATransmission 'Client), subQ :: TBQueue (ATransmission 'Agent), msgQ :: TBQueue (ServerTransmission BrokerMsg), - smpServers :: TVar (NonEmpty SMPServerWithAuth), - smpClients :: TMap SMPServer SMPClientVar, + smpServers :: TMap UserId (NonEmpty SMPServerWithAuth), + smpClients :: TMap SMPTransportSession SMPClientVar, ntfServers :: TVar [NtfServer], - ntfClients :: TMap NtfServer NtfClientVar, + ntfClients :: TMap NtfTransportSession NtfClientVar, useNetworkConfig :: TVar NetworkConfig, subscrConns :: TVar (Set ConnId), activeSubs :: TRcvQueues, @@ -195,7 +206,7 @@ data AgentClient = AgentClient -- locks to prevent concurrent operations with connection connLocks :: TMap ConnId Lock, -- locks to prevent concurrent reconnections to SMP servers - reconnectLocks :: TMap SMPServer Lock, + reconnectLocks :: TMap SMPTransportSession Lock, reconnections :: TVar [Async ()], asyncClients :: TVar [Async ()], agentStats :: TMap AgentStatsKey (TVar Int), @@ -227,7 +238,13 @@ data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map St instance ToJSON AgentLocks where toEncoding = J.genericToEncoding J.defaultOptions -data AgentStatsKey = AgentStatsKey {host :: ByteString, clientTs :: ByteString, cmd :: ByteString, res :: ByteString} +data AgentStatsKey = AgentStatsKey + { userId :: UserId, + host :: ByteString, + clientTs :: ByteString, + cmd :: ByteString, + res :: ByteString + } deriving (Eq, Ord, Show) newAgentClient :: InitialAgentServers -> Env -> STM AgentClient @@ -270,7 +287,7 @@ agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store class ProtocolServerClient msg where - getProtocolServerClient :: AgentMonad m => AgentClient -> ProtoServer msg -> m (ProtocolClient msg) + getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient msg) clientProtocolError :: ErrorType -> AgentErrorType instance ProtocolServerClient BrokerMsg where @@ -281,19 +298,20 @@ instance ProtocolServerClient NtfResponse where getProtocolServerClient = getNtfServerClient clientProtocolError = NTF -getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient -getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do +getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient +getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, entityId_) = do unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped" - atomically (getClientVar srv smpClients) + atomically (getClientVar tSess smpClients) >>= either - (newProtocolClient c srv smpClients connectClient reconnectClient) - (waitForProtocolClient c srv) + (newProtocolClient c tSess smpClients connectClient reconnectClient) + (waitForProtocolClient c tSess) where connectClient :: m SMPClient connectClient = do cfg <- getClientConfig c smpCfg u <- askUnliftIO - liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u) + let proxyUsername = Just $ bshow userId <> maybe "" (":" <>) entityId_ + liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient srv cfg proxyUsername (Just msgQ) $ clientDisconnected u) clientDisconnected :: UnliftIO m -> SMPClient -> IO () clientDisconnected u client = do @@ -302,14 +320,14 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do where removeClientAndSubs :: IO ([RcvQueue], [ConnId]) removeClientAndSubs = atomically $ do - TM.delete srv smpClients + TM.delete tSess smpClients (qs, conns) <- RQ.getDelSrvQueues srv $ activeSubs c mapM_ (`RQ.addQueue` pendingSubs c) qs pure (qs, S.toList conns) serverDown :: ([RcvQueue], [ConnId]) -> IO () serverDown (qs, conns) = whenM (readTVarIO active) $ do - incClientStat c client "DISCONNECT" "" + incClientStat c userId client "DISCONNECT" "" notifySub "" $ hostEvent DISCONNECT client unless (null conns) $ notifySub "" $ DOWN srv conns unless (null qs) $ do @@ -329,18 +347,20 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do reconnectClient :: m () reconnectClient = - withLockMap_ (reconnectLocks c) srv "reconnect" $ + withLockMap_ (reconnectLocks c) tSess "reconnect" $ atomically (RQ.getSrvQueues srv $ pendingSubs c) >>= resubscribe where resubscribe :: [RcvQueue] -> m () resubscribe qs = do - connected <- maybe False isRight <$> atomically (TM.lookup srv smpClients $>>= tryReadTMVar) + connected <- maybe False isRight <$> atomically (TM.lookup tSess smpClients $>>= tryReadTMVar) cs <- atomically . RQ.getConns $ activeSubs c + -- TODO probably tSess should be passed here or nothing + -- maybe this should be another function, not subscribeQueues (client_, rs) <- subscribeQueues c srv qs let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs liftIO $ do unless connected . forM_ client_ $ \cl -> do - incClientStat c cl "CONNECT" "" + incClientStat c userId cl "CONNECT" "" notifySub "" $ hostEvent CONNECT cl let conns = S.toList $ S.fromList okConns `S.difference` cs unless (null conns) $ notifySub "" $ UP srv conns @@ -351,37 +371,37 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do notifySub :: ConnId -> ACommand 'Agent -> IO () notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd) -getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfServer -> m NtfClient -getNtfServerClient c@AgentClient {active, ntfClients} srv = do +getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient +getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped" - atomically (getClientVar srv ntfClients) + atomically (getClientVar tSess ntfClients) >>= either - (newProtocolClient c srv ntfClients connectClient $ pure ()) - (waitForProtocolClient c srv) + (newProtocolClient c tSess ntfClients connectClient $ pure ()) + (waitForProtocolClient c tSess) where connectClient :: m NtfClient connectClient = do cfg <- getClientConfig c ntfCfg - liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient srv cfg Nothing clientDisconnected) + liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient srv cfg Nothing Nothing clientDisconnected) clientDisconnected :: NtfClient -> IO () clientDisconnected client = do - atomically $ TM.delete srv ntfClients - incClientStat c client "DISCONNECT" "" + atomically $ TM.delete tSess ntfClients + incClientStat c userId client "DISCONNECT" "" atomically $ writeTBQueue (subQ c) ("", "", hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv -getClientVar :: forall a s. ProtocolServer s -> TMap (ProtocolServer s) (TMVar a) -> STM (Either (TMVar a) (TMVar a)) -getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients +getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a)) +getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup tSess clients where newClientVar :: STM (TMVar a) newClientVar = do var <- newEmptyTMVar - TM.insert srv var clients + TM.insert tSess var clients pure var -waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> ProtoServer msg -> ClientVar msg -> m (ProtocolClient msg) -waitForProtocolClient c srv clientVar = do +waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar msg -> m (ProtocolClient msg) +waitForProtocolClient c (_, srv, _) clientVar = do NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar) liftEither $ case client_ of @@ -393,30 +413,30 @@ newProtocolClient :: forall msg m. (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> - ProtoServer msg -> - TMap (ProtoServer msg) (ClientVar msg) -> + TransportSession msg -> + TMap (TransportSession msg) (ClientVar msg) -> m (ProtocolClient msg) -> m () -> ClientVar msg -> m (ProtocolClient msg) -newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync +newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync where tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a tryConnectClient successAction retryAction = tryError connectClient >>= \r -> case r of Right client -> do - logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv + logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")" atomically $ putTMVar clientVar r - liftIO $ incClientStat c client "CLIENT" "OK" + liftIO $ incClientStat c userId client "CLIENT" "OK" atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client) successAction client Left e -> do - liftIO $ incServerStat c srv "CLIENT" $ strEncode e + liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e if temporaryAgentError e then retryAction else atomically $ do putTMVar clientVar (Left e) - TM.delete srv clients + TM.delete tSess clients throwError e tryConnectAsync :: m () tryConnectAsync = do @@ -471,7 +491,7 @@ throwWhenNoDelivery c SndQueue {server, sndId} = where k = (server, sndId) -closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO () +closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO () closeProtocolServerClients c clientsSel = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty) where @@ -494,30 +514,43 @@ withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pur where newLock = newEmptyTMVar >>= \l -> TM.insert key l locks $> l -withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> ByteString -> (ProtocolClient msg -> m a) -> m a -withClient_ c srv statCmd action = do - cl <- getProtocolServerClient c srv +withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient msg -> m a) -> m a +withClient_ c tSess@(userId, srv, _) statCmd action = do + cl <- getProtocolServerClient c tSess (action cl <* stat cl "OK") `catchError` logServerError cl where - stat cl = liftIO . incClientStat c cl statCmd + stat cl = liftIO . incClientStat c userId cl statCmd logServerError :: ProtocolClient msg -> AgentErrorType -> m a logServerError cl e = do logServer "<--" c srv "" $ strEncode e stat cl $ strEncode e throwError e -withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a -withLogClient_ c srv qId cmdStr action = do - logServer "-->" c srv qId cmdStr - res <- withClient_ c srv cmdStr action - logServer "<--" c srv qId "OK" +withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient msg -> m a) -> m a +withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do + logServer "-->" c srv entId cmdStr + res <- withClient_ c tSess cmdStr action + logServer "<--" c srv entId "OK" return res -withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> ProtoServer msg -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a -withClient c srv statKey action = withClient_ c srv statKey $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client +withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a +withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client -withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a -withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client +withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a +withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client + +withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT ProtocolClientError IO a) -> m a +withSMPClient c q cmdStr action = do + tSess <- mkSMPTransportSession c q + withLogClient c tSess (queueId q) cmdStr action + +withSMPClient_ :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> m a) -> m a +withSMPClient_ c q cmdStr action = do + tSess <- mkSMPTransportSession c q + withLogClient_ c tSess (queueId q) cmdStr action + +withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT ProtocolClientError IO a) -> m a +withNtfClient c srv = withLogClient c (0, srv, Nothing) liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> HostName -> ExceptT ProtocolClientError IO a -> m a liftClient protocolError_ = liftError . protocolClientError protocolError_ @@ -551,12 +584,13 @@ instance ToJSON SMPTestFailure where toEncoding = J.genericToEncoding J.defaultOptions toJSON = J.genericToJSON J.defaultOptions -runSMPServerTest :: AgentMonad m => AgentClient -> SMPServerWithAuth -> m (Maybe SMPTestFailure) -runSMPServerTest c (ProtoServerWithAuth srv auth) = do +runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure) +runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.SignAlg a <- asks $ cmdSignAlg . config liftIO $ do - getProtocolClient srv cfg Nothing (\_ -> pure ()) >>= \case + let proxyUsername = bshow userId + getProtocolClient srv cfg (Just proxyUsername) Nothing (\_ -> pure ()) >>= \case Right smp -> do (rKey, rpKey) <- C.generateSignatureKeyPair a (sKey, _) <- C.generateSignatureKeyPair a @@ -566,7 +600,7 @@ runSMPServerTest c (ProtoServerWithAuth srv auth) = do liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp - incClientStat c smp "TEST" "OK" + incClientStat c userId smp "TEST" "OK" pure $ either Just (const Nothing) r <|> maybe (Just (SMPTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -574,19 +608,29 @@ runSMPServerTest c (ProtoServerWithAuth srv auth) = do testErr :: SMPTestStep -> ProtocolClientError -> SMPTestFailure testErr step = SMPTestFailure step . protocolClientError SMP addr -newRcvQueue :: AgentMonad m => AgentClient -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri) -newRcvQueue c connId (ProtoServerWithAuth srv auth) vRange = do +mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg) +mkTransportSession c userId srv entityId = do + mode <- sessionMode <$> readTVarIO (useNetworkConfig c) + pure (userId, srv, if mode == TSMEntity then Just entityId else Nothing) + +mkSMPTransportSession :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession +mkSMPTransportSession c q = mkTransportSession c (qUserId q) (qServer q) (queueId q) + +newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri) +newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do C.SignAlg a <- asks (cmdSignAlg . config) (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a (dhKey, privDhKey) <- liftIO C.generateKeyPair' (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair' logServer "-->" c srv "" "NEW" + tSess <- mkTransportSession c userId srv connId QIK {rcvId, sndId, rcvPublicDhKey} <- - withClient c srv "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth + withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue - { connId, + { userId, + connId, server = srv, rcvId, rcvPrivateKey, @@ -609,7 +653,7 @@ subscribeQueue c rq@RcvQueue {connId, server, rcvPrivateKey, rcvId} = do atomically $ do modifyTVar (subscrConns c) $ S.insert connId RQ.addQueue rq $ pendingSubs c - withLogClient c server rcvId "SUB" $ \smp -> + withSMPClient c rq "SUB" $ \smp -> liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq) >>= either throwError pure @@ -648,14 +692,19 @@ subscribeQueues c srv qs = do RQ.addQueue rq $ pendingSubs c case L.nonEmpty qs_ of Just qs' -> do - smp_ <- tryError (getSMPServerClient c srv) + mode <- sessionMode <$> readTVarIO (useNetworkConfig c) + -- TODO these subscriptions should happen in different sessions if mode is TSMEntity + -- it is also a question whether it is needed to group by server outside if grouping by sessions should happen here anyway + let userId = 1 + tSess = (userId, srv, Nothing) + smp_ <- tryError $ getSMPServerClient c tSess (eitherToMaybe smp_,) . (errs <>) <$> case smp_ of Left e -> pure $ map (,Left e) qs_ Right smp -> do logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB" let qs2 = L.map queueCreds qs' n = (length qs2 - 1) `div` 90 + 1 - liftIO $ incClientStatN c smp n "SUBS" "OK" + liftIO $ incClientStatN c userId smp n "SUBS" "OK" liftIO $ do rs <- zip qs_ . L.toList <$> subscribeSMPQueues smp qs2 mapM_ (uncurry $ processSubResult c) rs @@ -699,16 +748,17 @@ logSecret :: ByteString -> ByteString logSecret bs = encode $ B.take 3 bs sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m () -sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = - withLogClient_ c server sndId "SEND " $ \smp -> do +sendConfirmation c sq@SndQueue {sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = + withSMPClient_ c sq "SEND " $ \smp -> do let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" -sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m () -sendInvitation c (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = - withLogClient_ c smpServer senderId "SEND " $ \smp -> do +sendInvitation :: forall m. AgentMonad m => AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m () +sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do + tSess <- mkTransportSession c userId smpServer senderId + withLogClient_ c tSess senderId "SEND " $ \smp -> do msg <- mkInvitation liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg where @@ -722,7 +772,7 @@ sendInvitation c (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderI getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta) getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do atomically createTakeGetLock - (v, msg_) <- withLogClient c server rcvId "GET" $ \smp -> + (v, msg_) <- withSMPClient c rq "GET" $ \smp -> (thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId mapM (decryptMeta v) msg_ where @@ -742,23 +792,23 @@ decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.Enc decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId) secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m () -secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey = - withLogClient c server rcvId "KEY " $ \smp -> +secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = + withSMPClient c rq "KEY " $ \smp -> secureSMPQueue smp rcvPrivateKey rcvId senderKey enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (NotifierId, RcvNtfPublicDhKey) -enableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = - withLogClient c server rcvId "NKEY " $ \smp -> +enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = + withSMPClient c rq "NKEY " $ \smp -> enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m () -disableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} = - withLogClient c server rcvId "NDEL" $ \smp -> +disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} = + withSMPClient c rq "NDEL" $ \smp -> disableSMPQueueNotifications smp rcvPrivateKey rcvId sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m () -sendAck c rq@RcvQueue {server, rcvId, rcvPrivateKey} msgId = do - withLogClient c server rcvId "ACK" $ \smp -> +sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do + withSMPClient c rq "ACK" $ \smp -> ackSMPMessage smp rcvPrivateKey rcvId msgId atomically $ releaseGetLock c rq @@ -767,57 +817,57 @@ releaseGetLock c RcvQueue {server, rcvId} = TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ()) suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () -suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} = - withLogClient c server rcvId "OFF" $ \smp -> +suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = + withSMPClient c rq "OFF" $ \smp -> suspendSMPQueue smp rcvPrivateKey rcvId deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () -deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} = - withLogClient c server rcvId "DEL" $ \smp -> +deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = + withSMPClient c rq "DEL" $ \smp -> deleteSMPQueue smp rcvPrivateKey rcvId -sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m () -sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msgFlags agentMsg = - withLogClient_ c server sndId "SEND " $ \smp -> do +sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m () +sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg = + withSMPClient_ c sq "SEND " $ \smp -> do let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg liftClient SMP (clientServer smp) $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = - withClient c ntfServer "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) + withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m () agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code = - withLogClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code + withNtfClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m NtfTknStatus agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} = - withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId + withNtfClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId agentNtfReplaceToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> m () agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token = - withLogClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token + withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m () agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} = - withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId + withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> Word16 -> m () agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval = - withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval + withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> NtfPrivateSignKey -> m NtfSubscriptionId agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey = - withLogClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey) + withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey) agentNtfCheckSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m NtfSubStatus agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} = - withLogClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId + withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m () agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} = - withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId + withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do @@ -948,18 +998,18 @@ incStat AgentClient {agentStats} n k = do Just v -> modifyTVar v (+ n) _ -> newTVar n >>= \v -> TM.insert k v agentStats -incClientStat :: AgentClient -> ProtocolClient msg -> ByteString -> ByteString -> IO () -incClientStat c pc = incClientStatN c pc 1 +incClientStat :: AgentClient -> UserId -> ProtocolClient msg -> ByteString -> ByteString -> IO () +incClientStat c userId pc = incClientStatN c userId pc 1 -incServerStat :: AgentClient -> ProtocolServer p -> ByteString -> ByteString -> IO () -incServerStat c ProtocolServer {host} cmd res = do +incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO () +incServerStat c userId ProtocolServer {host} cmd res = do threadDelay 100000 atomically $ incStat c 1 statsKey where - statsKey = AgentStatsKey {host = strEncode $ L.head host, clientTs = "", cmd, res} + statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res} -incClientStatN :: AgentClient -> ProtocolClient msg -> Int -> ByteString -> ByteString -> IO () -incClientStatN c pc n cmd res = do +incClientStatN :: AgentClient -> UserId -> ProtocolClient msg -> Int -> ByteString -> ByteString -> IO () +incClientStatN c userId pc n cmd res = do atomically $ incStat c n statsKey where - statsKey = AgentStatsKey {host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res} + statsKey = AgentStatsKey {userId, host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res} diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 60afe9bcf..f20ed2f00 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -32,12 +32,14 @@ import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) import Data.Time.Clock (NominalDiffTime, nominalDay) import Data.Word (Word16) import Network.Socket import Numeric.Natural import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Store (UserId) import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client @@ -59,7 +61,7 @@ import UnliftIO.STM type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m) data InitialAgentServers = InitialAgentServers - { smp :: NonEmpty SMPServerWithAuth, + { smp :: Map UserId (NonEmpty SMPServerWithAuth), ntf :: [NtfServer], netCfg :: NetworkConfig } diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 4b45c07bd..cff4ca125 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -34,6 +34,7 @@ import Simplex.Messaging.Protocol NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, + QueueId, RcvDhSecret, RcvNtfDhSecret, RcvPrivateSignKey, @@ -47,7 +48,8 @@ import Simplex.Messaging.Version -- | A receive queue. SMP queue through which the agent receives messages from a sender. data RcvQueue = RcvQueue - { connId :: ConnId, + { userId :: UserId, + connId :: ConnId, server :: SMPServer, -- | recipient queue ID rcvId :: SMP.RecipientId, @@ -89,7 +91,8 @@ data ClientNtfCreds = ClientNtfCreds -- | A send queue. SMP queue through which the agent sends messages to a recipient. data SndQueue = SndQueue - { connId :: ConnId, + { userId :: UserId, + connId :: ConnId, server :: SMPServer, -- | sender queue ID sndId :: SMP.SenderId, @@ -150,6 +153,27 @@ findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue findRQ sAddr = find $ sameQAddress sAddr . sndAddress {-# INLINE findRQ #-} +class SMPQueue q => SMPQueueRec q where + qUserId :: q -> UserId + qConnId :: q -> ConnId + queueId :: q -> QueueId + +instance SMPQueueRec RcvQueue where + qUserId = userId + {-# INLINE qUserId #-} + qConnId = connId + {-# INLINE qConnId #-} + queueId = rcvId + {-# INLINE queueId #-} + +instance SMPQueueRec SndQueue where + qUserId = userId + {-# INLINE qUserId #-} + qConnId = connId + {-# INLINE qConnId #-} + queueId = sndId + {-# INLINE queueId #-} + -- * Connection types -- | Type of a connection. @@ -222,6 +246,7 @@ deriving instance Show SomeConn data ConnData = ConnData { connId :: ConnId, + userId :: UserId, connAgentVersion :: Version, enableNtfs :: Bool, duplexHandshake :: Maybe Bool, -- added in agent protocol v2 @@ -231,6 +256,8 @@ data ConnData = ConnData data AgentCmdType = ACClient | ACInternal +type UserId = Int64 + instance StrEncoding AgentCmdType where strEncode = \case ACClient -> "CLIENT" @@ -471,6 +498,8 @@ data StoreError SEInternal ByteString | -- | Failed to generate unique random ID SEUniqueID + | -- | User ID not found + SEUserNotFound | -- | Connection not found (or both queues absent). SEConnNotFound | -- | Connection already used. diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 135e1b43c..d3c2b7acf 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -27,6 +27,10 @@ module Simplex.Messaging.Agent.Store.SQLite sqlString, execSQL, + -- * Users + createUserRecord, + deleteUserRecord, + -- * Queues and connections createNewConn, updateNewConnRcv, @@ -297,6 +301,18 @@ withTransaction st action = withConnection st $ loop 500 2_000_000 loop (t * 9 `div` 8) (tLim - t) db else E.throwIO e +createUserRecord :: DB.Connection -> IO UserId +createUserRecord db = do + DB.execute_ db "INSERT INTO users () VALUES ()" + insertedRowId db + +deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ()) +deleteUserRecord db userId = runExceptT $ do + _ :: Only Int64 <- + ExceptT . firstRow id SEUserNotFound $ + DB.query db "SELECT user_id FROM users WHERE user_id = ?" (Only userId) + liftIO $ DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) + createConn_ :: TVar ChaChaDRG -> ConnData -> @@ -307,9 +323,9 @@ createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of ConnData {connId} -> create connId $> Right connId createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId) -createNewConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} cMode = +createNewConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} cMode = createConn_ gVar cData $ \connId -> do - DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake) + DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake) updateNewConnRcv :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64) updateNewConnRcv db connId rq = @@ -332,17 +348,17 @@ updateNewConnSnd db connId sq = updateConn = Right <$> addConnSndQueue_ db connId sq createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId) -createRcvConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode = +createRcvConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode = createConn_ gVar cData $ \connId -> do upsertServer_ db server - DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake) + DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake) void $ insertRcvQueue_ db connId q createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId) -createSndConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} = +createSndConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} = createConn_ gVar cData $ \connId -> do upsertServer_ db server - DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake) + DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake) void $ insertSndQueue_ db connId q getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn)) @@ -1328,9 +1344,9 @@ getAnyConn dbConn connId deleted' = getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode)) getConnData dbConn connId' = - maybeFirstRow cData $ DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId') + maybeFirstRow cData $ DB.query dbConn "SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId') where - cData (connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode) + cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode) setConnDeleted :: DB.Connection -> ConnId -> IO () setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId) @@ -1348,31 +1364,32 @@ getRcvQueuesByConnId_ db connId = rcvQueueQuery :: Query rcvQueueQuery = [sql| - SELECT s.key_hash, q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, + SELECT c.user_id, s.key_hash, q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status, q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret FROM rcv_queues q - INNER JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN connections c ON q.conn_id = c.conn_id |] toRcvQueue :: - (C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) :. (Int64, Bool, Maybe Int64, Maybe Version) :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue -toRcvQueue ((keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash smpClientVersion = fromMaybe 1 smpClientVersion_ clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} _ -> Nothing - in RcvQueue {connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds} + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds} getRcvQueueById_ :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById_ db connId dbRcvId = firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> " WHERE conn_id = ? AND rcv_queue_id = ?") (connId, dbRcvId) + DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ?") (connId, dbRcvId) -- | returns all connection queues, the first queue is the primary one getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue)) @@ -1381,16 +1398,17 @@ getSndQueuesByConnId_ dbConn connId = <$> DB.query dbConn [sql| - SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version + SELECT c.user_id, s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version FROM snd_queues q - INNER JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN connections c ON q.conn_id = c.conn_id WHERE q.conn_id = ?; |] (Only connId) where - sndQueue ((keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) = + sndQueue ((userId, keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) = let server = SMPServer host port keyHash - in SndQueue {connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion} + in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion} primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} = -- the current primary queue is ordered first, the next primary - second compare (Down p) (Down p') <> compare i i' diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 43f99cb94..386a0eab1 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -37,6 +37,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport.Client (TransportHost) @@ -53,7 +54,8 @@ schemaMigrations = ("m20220811_onion_hosts", m20220811_onion_hosts), ("m20220817_connection_ntfs", m20220817_connection_ntfs), ("m20220905_commands", m20220905_commands), - ("m20220915_connection_queues", m20220915_connection_queues) + ("m20220915_connection_queues", m20220915_connection_queues), + ("m20230110_users", m20230110_users) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs new file mode 100644 index 000000000..a56930ad0 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230110_users :: Query +m20230110_users = + [sql| +PRAGMA ignore_check_constraints=ON; + +CREATE TABLE users ( + user_id INTEGER PRIMARY KEY AUTOINCREMENT +); + +INSERT INTO users (user_id) VALUES (1); + +ALTER TABLE connections ADD COLUMN user_id INTEGER CHECK (user_id NOT NULL) +REFERENCES users ON DELETE CASCADE; + +CREATE INDEX idx_connections_user ON connections(user_id); + +UPDATE connections SET user_id = 1; + +PRAGMA ignore_check_constraints=OFF; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 9c39ffa56..548aaa63c 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -22,7 +22,9 @@ CREATE TABLE connections( , duplex_handshake INTEGER NULL DEFAULT 0, enable_ntfs INTEGER, - deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL) + deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL), + user_id INTEGER CHECK(user_id NOT NULL) + REFERENCES users ON DELETE CASCADE ) WITHOUT ROWID; CREATE TABLE rcv_queues( host TEXT NOT NULL, @@ -228,3 +230,5 @@ CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries( conn_id, snd_queue_id ); +CREATE TABLE users(user_id INTEGER PRIMARY KEY AUTOINCREMENT); +CREATE INDEX idx_connections_user ON connections(user_id); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 611702b69..dcf1e3e10 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -54,6 +54,7 @@ module Simplex.Messaging.Client ProtocolClientError (..), ProtocolClientConfig (..), NetworkConfig (..), + TransportSessionMode (..), defaultClientConfig, defaultNetworkConfig, transportClientConfig, @@ -152,6 +153,8 @@ data NetworkConfig = NetworkConfig hostMode :: HostMode, -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host requiredHostMode :: Bool, + -- | transport sessions are created per user or per entity + sessionMode :: TransportSessionMode, -- | timeout for the initial client TCP/TLS connection (microseconds) tcpConnectTimeout :: Int, -- | timeout of protocol commands (microseconds) @@ -168,12 +171,23 @@ instance ToJSON NetworkConfig where toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +data TransportSessionMode = TSMUser | TSMEntity + deriving (Eq, Show, Generic) + +instance ToJSON TransportSessionMode where + toJSON = J.genericToJSON . enumJSON $ dropPrefix "TSM" + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TSM" + +instance FromJSON TransportSessionMode where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "TSM" + defaultNetworkConfig :: NetworkConfig defaultNetworkConfig = NetworkConfig { socksProxy = Nothing, hostMode = HMOnionViaSocks, requiredHostMode = False, + sessionMode = TSMUser, tcpConnectTimeout = 7_500_000, tcpTimeout = 5_000_000, tcpKeepAlive = Just defaultKeepAliveOpts, @@ -239,8 +253,8 @@ transportHost' = transportHost . client_ -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg)) -getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do +getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe ByteString -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg)) +getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} proxyUsername msgQ disconnected = do case chooseTransportHost networkConfig (host protocolServer) of Right useHost -> (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost) @@ -274,7 +288,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, let tcConfig = transportClientConfig networkConfig action <- async $ - runTransportClient tcConfig useHost port' (Just $ keyHash protocolServer) (client t c cVar) + runTransportClient tcConfig proxyUsername useHost port' (Just $ keyHash protocolServer) (client t c cVar) `finally` atomically (putTMVar cVar $ Left PCENetworkError) c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar) pure $ case c_ of diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index d5f12942c..f2fe97666 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -160,7 +160,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = void $ tryConnectClient (const reconnectClient) loop connectClient :: ExceptT ProtocolClientError IO SMPClient - connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected + connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) Nothing (Just msgQ) clientDisconnected clientDisconnected :: SMPClient -> IO () clientDisconnected _ = do diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 0263e374e..a6897074d 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -77,6 +77,7 @@ module Simplex.Messaging.Protocol BasicAuth (..), SrvLoc (..), CorrId (..), + EntityId, QueueId, RecipientId, SenderId, diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index d6f95f20a..f7af991a4 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -107,15 +107,15 @@ defaultTransportClientConfig :: TransportClientConfig defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True -- | Connect to passed TCP host:port and pass handle to the client. -runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a +runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a runTransportClient = runTLSTransportClient supportedParameters Nothing -runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a -runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} host port keyHash client = do +runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a +runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} proxyUsername host port keyHash client = do let hostName = B.unpack $ strEncode host clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash connectTCP = case socksProxy of - Just proxy -> connectSocksClient proxy $ hostAddr host + Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host _ -> connectTCPClient hostName c <- liftIO $ do sock <- connectTCP port @@ -153,10 +153,12 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err defaultSMPPort :: PortNumber defaultSMPPort = 5223 -connectSocksClient :: SocksProxy -> SocksHostAddress -> ServiceName -> IO Socket -connectSocksClient (SocksProxy addr) hostAddr _port = do +connectSocksClient :: SocksProxy -> Maybe ByteString -> SocksHostAddress -> ServiceName -> IO Socket +connectSocksClient (SocksProxy addr) proxyUsername hostAddr _port = do let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port - fst <$> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port) + fst <$> case proxyUsername of + Just username -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) (SocksCredentials username "") + _ -> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port) defaultSocksHost :: HostAddress defaultSocksHost = tupleToHostAddress (127, 0, 0, 1) diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index 085af91a6..d0efe2060 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -120,7 +120,7 @@ sendRequest HTTP2Client {reqQ, config} req = do runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> HostName -> ServiceName -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO () runHTTP2Client tlsParams caStore tcConfig host port client = - runTLSTransportClient tlsParams caStore tcConfig (THDomainName host) port Nothing $ \c -> + runTLSTransportClient tlsParams caStore tcConfig Nothing (THDomainName host) port Nothing $ \c -> withTlsConfig c 16384 (`run` client) where run = H.run $ ClientConfig "https" (B.pack host) 20 diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 7f69070c6..d70d5705d 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -218,8 +218,8 @@ runTestCfg2 aliceCfg bobCfg baseMsgId runTest = do runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientTest alice bob baseId = do Right () <- runExceptT $ do - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -254,8 +254,8 @@ runAgentClientTest alice bob baseId = do runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientContactTest alice bob baseId = do Right () <- runExceptT $ do - (_, qInfo) <- createConnection alice True SCMContact Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (_, qInfo) <- createConnection alice 1 True SCMContact Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, REQ invId _ "bob's connInfo") <- get alice bobId <- acceptContact alice True invId "alice's connInfo" ("", _, CONF confId _ "alice's connInfo") <- get bob @@ -302,9 +302,9 @@ testAsyncInitiatingOffline = do alice <- getSMPAgentClient agentCfg initAgentServers bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right () <- runExceptT $ do - (bobId, cReq) <- createConnection alice True SCMInvitation Nothing + (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing disconnectAgentClient alice - aliceId <- joinConnection bob True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers subscribeConnection alice' bobId ("", _, CONF confId _ "bob's connInfo") <- get alice' @@ -320,8 +320,8 @@ testAsyncJoiningOfflineBeforeActivation = do alice <- getSMPAgentClient agentCfg initAgentServers bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right () <- runExceptT $ do - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" disconnectAgentClient bob ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" @@ -338,9 +338,9 @@ testAsyncBothOffline = do alice <- getSMPAgentClient agentCfg initAgentServers bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right () <- runExceptT $ do - (bobId, cReq) <- createConnection alice True SCMInvitation Nothing + (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing disconnectAgentClient alice - aliceId <- joinConnection bob True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" disconnectAgentClient bob alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers subscribeConnection alice' bobId @@ -360,9 +360,9 @@ testAsyncServerOffline t = do bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers -- create connection and shutdown the server Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ -> - runExceptT $ createConnection alice True SCMInvitation Nothing + runExceptT $ createConnection alice 1 True SCMInvitation Nothing -- connection fails - Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob True cReq "bob's connInfo" + Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" ("", "", DOWN srv conns) <- get alice srv `shouldBe` testSMPServer conns `shouldBe` [bobId] @@ -372,7 +372,7 @@ testAsyncServerOffline t = do liftIO $ do srv1 `shouldBe` testSMPServer conns1 `shouldBe` [bobId] - aliceId <- joinConnection bob True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -387,9 +387,9 @@ testAsyncHelloTimeout = do alice <- getSMPAgentClient agentCfgV1 initAgentServers bob <- getSMPAgentClient agentCfg {database = testDB2, helloTimeout = 1} initAgentServers Right () <- runExceptT $ do - (_, cReq) <- createConnection alice True SCMInvitation Nothing + (_, cReq) <- createConnection alice 1 True SCMInvitation Nothing disconnectAgentClient alice - aliceId <- joinConnection bob True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED) pure () @@ -444,8 +444,8 @@ testDuplicateMessage t = do makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnection alice bob = do - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -459,7 +459,7 @@ testInactiveClientDisconnected t = do withSmpServerConfigOn t cfg' testPort $ \_ -> do alice <- getSMPAgentClient agentCfg initAgentServers Right () <- runExceptT $ do - (connId, _cReq) <- createConnection alice True SCMInvitation Nothing + (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing get alice ##> ("", "", DOWN testSMPServer [connId]) pure () @@ -470,7 +470,7 @@ testActiveClientNotDisconnected t = do alice <- getSMPAgentClient agentCfg initAgentServers ts <- getSystemTime Right () <- runExceptT $ do - (connId, _cReq) <- createConnection alice True SCMInvitation Nothing + (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing keepSubscribing alice connId ts pure () where @@ -619,10 +619,10 @@ testAsyncCommands = do alice <- getSMPAgentClient agentCfg initAgentServers bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right () <- runExceptT $ do - bobId <- createConnectionAsync alice "1" True SCMInvitation + bobId <- createConnectionAsync alice 1 "1" True SCMInvitation ("1", bobId', INV (ACR _ qInfo)) <- get alice liftIO $ bobId' `shouldBe` bobId - aliceId <- joinConnectionAsync bob "2" True qInfo "bob's connInfo" + aliceId <- joinConnectionAsync bob 1 "2" True qInfo "bob's connInfo" ("2", aliceId', OK) <- get bob liftIO $ aliceId' `shouldBe` aliceId ("", _, CONF confId _ "bob's connInfo") <- get alice @@ -663,7 +663,7 @@ testAsyncCommands = do testAsyncCommandsRestore :: ATransport -> IO () testAsyncCommandsRestore t = do alice <- getSMPAgentClient agentCfg initAgentServers - Right bobId <- runExceptT $ createConnectionAsync alice "1" True SCMInvitation + Right bobId <- runExceptT $ createConnectionAsync alice 1 "1" True SCMInvitation liftIO $ noMessages alice "alice doesn't receive INV because server is down" disconnectAgentClient alice alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers @@ -679,8 +679,8 @@ testAcceptContactAsync = do alice <- getSMPAgentClient agentCfg initAgentServers bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right () <- runExceptT $ do - (_, qInfo) <- createConnection alice True SCMContact Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (_, qInfo) <- createConnection alice 1 True SCMContact Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, REQ invId _ "bob's connInfo") <- get alice bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" ("1", bobId', OK) <- get alice @@ -808,11 +808,11 @@ testCreateQueueAuth clnt1 clnt2 = do a <- getClient clnt1 b <- getClient clnt2 Right created <- runExceptT $ do - tryError (createConnection a True SCMInvitation Nothing) >>= \case + tryError (createConnection a 1 True SCMInvitation Nothing) >>= \case Left (SMP AUTH) -> pure 0 Left e -> throwError e Right (bId, qInfo) -> - tryError (joinConnection b True qInfo "bob's connInfo") >>= \case + tryError (joinConnection b 1 True qInfo "bob's connInfo") >>= \case Left (SMP AUTH) -> pure 1 Left e -> throwError e Right aId -> do @@ -826,7 +826,7 @@ testCreateQueueAuth clnt1 clnt2 = do pure created where getClient (clntAuth, clntVersion) = - let servers = initAgentServers {smp = [ProtoServerWithAuth testSMPServer clntAuth]} + let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]} smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion} in getSMPAgentClient agentCfg {smpCfg} servers @@ -834,7 +834,7 @@ testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAut testSMPServerConnectionTest t newQueueBasicAuth srv = withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do a <- getSMPAgentClient agentCfg initAgentServers -- initially passed server is not running - Right r <- runExceptT $ testSMPServerConnection a srv + Right r <- runExceptT $ testSMPServerConnection a 1 srv pure r testRatchetAdHash :: IO () diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index d340a3522..62a8363ef 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -213,8 +213,8 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right (bobId, aliceId, nonce, message) <- runExceptT $ do -- establish connection - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get bob ##> ("", aliceId, INFO "alice's connInfo") @@ -275,9 +275,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ -- establish connection liftIO $ threadDelay 50000 - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing liftIO $ threadDelay 1000000 - aliceId <- joinConnection bob True qInfo "bob's connInfo" + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" liftIO $ threadDelay 750000 void $ messageNotification apnsQ ("", _, CONF confId _ "bob's connInfo") <- get alice @@ -327,8 +327,8 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right () <- runExceptT $ do -- establish connection - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get bob ##> ("", aliceId, INFO "alice's connInfo") @@ -392,8 +392,8 @@ testChangeToken APNSMockServer {apnsQ} = do bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers Right (aliceId, bobId) <- runExceptT $ do -- establish connection - (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing - aliceId <- joinConnection bob True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get bob ##> ("", aliceId, INFO "alice's connInfo") diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 072021461..1636571b6 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -140,7 +140,7 @@ testForeignKeysEnabled = `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint) cData1 :: ConnData -cData1 = ConnData {connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False} +cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False} testPrivateSignKey :: C.APrivateSignKey testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" @@ -154,7 +154,8 @@ testDhSecret = "01234567890123456789012345678901" rcvQueue1 :: RcvQueue rcvQueue1 = RcvQueue - { connId = "conn1", + { userId = 1, + connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, rcvId = "1234", rcvPrivateKey = testPrivateSignKey, @@ -173,7 +174,8 @@ rcvQueue1 = sndQueue1 :: SndQueue sndQueue1 = SndQueue - { connId = "conn1", + { userId = 1, + connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "3456", sndPublicKey = Nothing, @@ -314,7 +316,8 @@ testUpgradeRcvConnToDuplex = _ <- createSndConn db g cData1 sndQueue1 let anotherSndQueue = SndQueue - { connId = "conn1", + { userId = 1, + connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", sndPublicKey = Nothing, @@ -340,7 +343,8 @@ testUpgradeSndConnToDuplex = _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation let anotherRcvQueue = RcvQueue - { connId = "conn1", + { userId = 1, + connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, rcvId = "3456", rcvPrivateKey = testPrivateSignKey, diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index c4d614531..7c6c9fb2f 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -69,7 +69,7 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log" testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig host ntfTestPort (Just testKeyHash) $ \h -> + runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case Right th -> client th Left e -> error $ show e diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 16efc39f0..39f8c86d8 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -11,7 +12,8 @@ import Control.Monad.IO.Unlift import Crypto.Random import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Network.Socket (ServiceName) import NtfClient (ntfTestPort) import SMPClient @@ -27,6 +29,7 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) +import Simplex.Messaging.Agent.Store (UserId) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Transport @@ -173,13 +176,13 @@ testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5 initAgentServers :: InitialAgentServers initAgentServers = InitialAgentServers - { smp = L.fromList [noAuthSrv testSMPServer], + { smp = userServers [noAuthSrv testSMPServer], ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"], netCfg = defaultNetworkConfig {tcpTimeout = 500_000} } initAgentServers2 :: InitialAgentServers -initAgentServers2 = initAgentServers {smp = L.fromList [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]} +initAgentServers2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]} agentCfg :: AgentConfig agentCfg = @@ -209,11 +212,14 @@ agentCfg = withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> m () -> (ThreadId -> m a) -> m a withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess = let cfg' = agentCfg {tcpPort = port', database = db'} - initServers' = initAgentServers {smp = L.fromList [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]} + initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]} in serverBracket (\started -> runSMPAgentBlocking t started cfg' initServers') afterProcess +userServers :: NonEmpty SMPServerWithAuth -> Map UserId (NonEmpty SMPServerWithAuth) +userServers srvs = M.fromList [(1, srvs)] + withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> (ThreadId -> m a) -> m a withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile (dbFile db') @@ -226,7 +232,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB) testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a testSMPAgentClientOn port' client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost - runTransportClient defaultTransportClientConfig useHost port' (Just testKeyHash) $ \h -> do + runTransportClient defaultTransportClientConfig Nothing useHost port' (Just testKeyHash) $ \h -> do line <- liftIO $ getLn h if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion then client h diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 1bca4d060..b005699d3 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -57,7 +57,7 @@ testServerStatsBackupFile = "tests/tmp/smp-server-stats.log" testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testSMPClient client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig useHost testPort (Just testKeyHash) $ \h -> + runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case Right th -> client th Left e -> error $ show e From 8e024590bc2b4428e64e625a9c2392908fc5912e Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Fri, 13 Jan 2023 11:31:35 +0400 Subject: [PATCH 02/19] fix createUserRecord query (#604) --- src/Simplex/Messaging/Agent/Store/SQLite.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index d3c2b7acf..dfdc73103 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -303,7 +303,7 @@ withTransaction st action = withConnection st $ loop 500 2_000_000 createUserRecord :: DB.Connection -> IO UserId createUserRecord db = do - DB.execute_ db "INSERT INTO users () VALUES ()" + DB.execute_ db "INSERT INTO users DEFAULT VALUES" insertedRowId db deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ()) From 9c9ba8c25c9a6e6042cff184c0fd72524134755e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 13 Jan 2023 09:58:39 +0000 Subject: [PATCH 03/19] subscribe users in different sessions (#602) * subscribe users in different sessions * remove comments * include userId to rcv queue map key * use hash of userId[:entityId] as SOCKS proxy username --- src/Simplex/Messaging/Agent.hs | 13 +--- src/Simplex/Messaging/Agent/Client.hs | 92 ++++++++++++----------- src/Simplex/Messaging/Agent/TRcvQueues.hs | 45 +++++++---- 3 files changed, 84 insertions(+), 66 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index ce51df1aa..1074d9abd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -132,7 +132,7 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Random (randomR) -import UnliftIO.Async (async, mapConcurrently, race_) +import UnliftIO.Async (async, race_) import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -633,10 +633,9 @@ subscribeConnections' c connIds = do let (errs, cs) = M.mapEither id conns errs' = M.map (Left . storeError) errs (subRs, rcvQs) = M.mapEither rcvQueueOrResult cs - srvRcvQs :: Map SMPServer [RcvQueue] = M.foldl' (foldl' addRcvQueue) M.empty rcvQs mapM_ (mapM_ (\(cData, sqs) -> mapM_ (resumeMsgDelivery c cData) sqs) . sndQueue) cs mapM_ (resumeConnCmds c) $ M.keys cs - rcvRs <- connResults . concat <$> mapConcurrently subscribe (M.assocs srvRcvQs) + rcvRs <- connResults <$> subscribeQueues c (concat $ M.elems rcvQs) ns <- asks ntfSupervisor tkn <- readTVarIO (ntfTkn ns) when (instantNotifications tkn) . void . forkIO $ sendNtfCreate ns rcvRs conns @@ -644,9 +643,9 @@ subscribeConnections' c connIds = do notifyResultError rs pure rs where - rcvQueueOrResult :: SomeConn -> Either (Either AgentErrorType ()) (NonEmpty RcvQueue) + rcvQueueOrResult :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue] rcvQueueOrResult (SomeConn _ conn) = case conn of - DuplexConnection _ rqs _ -> Right rqs + DuplexConnection _ rqs _ -> Right $ L.toList rqs SndConnection _ sq -> Left $ sndSubResult sq RcvConnection _ rq -> Right [rq] ContactConnection _ rq -> Right [rq] @@ -656,10 +655,6 @@ subscribeConnections' c connIds = do Confirmed -> Right () Active -> Left $ CONN SIMPLEX _ -> Left $ INTERNAL "unexpected queue status" - addRcvQueue :: Map SMPServer [RcvQueue] -> RcvQueue -> Map SMPServer [RcvQueue] - addRcvQueue m rq@RcvQueue {server} = M.alter (Just . maybe [rq] (rq :)) server m - subscribe :: (SMPServer, [RcvQueue]) -> m [(RcvQueue, Either AgentErrorType ())] - subscribe (srv, qs) = snd <$> subscribeQueues c srv qs connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty where diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 875e8b66f..1b152b87f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -101,8 +101,8 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (isRight, partitionEithers) import Data.Functor (($>)) -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List (foldl', partition) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -160,7 +160,7 @@ import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Timeout (timeout) -import UnliftIO (async) +import UnliftIO (async, mapConcurrently) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -310,8 +310,8 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, connectClient = do cfg <- getClientConfig c smpCfg u <- askUnliftIO - let proxyUsername = Just $ bshow userId <> maybe "" (":" <>) entityId_ - liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient srv cfg proxyUsername (Just msgQ) $ clientDisconnected u) + let proxyUsername = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_ + liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient srv cfg (Just proxyUsername) (Just msgQ) $ clientDisconnected u) clientDisconnected :: UnliftIO m -> SMPClient -> IO () clientDisconnected u client = do @@ -321,7 +321,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, removeClientAndSubs :: IO ([RcvQueue], [ConnId]) removeClientAndSubs = atomically $ do TM.delete tSess smpClients - (qs, conns) <- RQ.getDelSrvQueues srv $ activeSubs c + (qs, conns) <- RQ.getDelSessQueues tSess $ activeSubs c mapM_ (`RQ.addQueue` pendingSubs c) qs pure (qs, S.toList conns) @@ -348,16 +348,17 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, reconnectClient :: m () reconnectClient = withLockMap_ (reconnectLocks c) tSess "reconnect" $ - atomically (RQ.getSrvQueues srv $ pendingSubs c) >>= resubscribe + atomically (RQ.getSessQueues tSess $ pendingSubs c) >>= mapM_ resubscribe . L.nonEmpty where - resubscribe :: [RcvQueue] -> m () + resubscribe :: NonEmpty RcvQueue -> m () resubscribe qs = do connected <- maybe False isRight <$> atomically (TM.lookup tSess smpClients $>>= tryReadTMVar) cs <- atomically . RQ.getConns $ activeSubs c - -- TODO probably tSess should be passed here or nothing - -- maybe this should be another function, not subscribeQueues - (client_, rs) <- subscribeQueues c srv qs - let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs + -- TODO the unsolved problem is changing session mode + -- currently it would reconnect the same client and will keep it around, until the app is restarted. + -- instead it should check whether session mode changed and connect somehow differently if it did... + (client_, rs) <- subscribeQueues_ c tSess qs + let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) $ L.toList rs liftIO $ do unless connected . forM_ client_ $ \cl -> do incClientStat c userId cl "CONNECT" "" @@ -589,7 +590,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.SignAlg a <- asks $ cmdSignAlg . config liftIO $ do - let proxyUsername = bshow userId + let proxyUsername = C.sha256Hash $ bshow userId getProtocolClient srv cfg (Just proxyUsername) Nothing (\_ -> pure ()) >>= \case Right smp -> do (rKey, rpKey) <- C.generateSignatureKeyPair a @@ -683,39 +684,42 @@ temporaryOrHostError = \case BROKER _ HOST -> True e -> temporaryAgentError e --- | subscribe multiple queues - all passed queues should be on the same server -subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> [RcvQueue] -> m (Maybe SMPClient, [(RcvQueue, Either AgentErrorType ())]) -subscribeQueues c srv qs = do - (errs, qs_) <- partitionEithers <$> mapM checkQueue qs - forM_ qs_ $ \rq@RcvQueue {connId} -> atomically $ do - modifyTVar' (subscrConns c) $ S.insert connId +subscribeQueues :: AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())] +subscribeQueues c qs = do + (errs, qs') <- partitionEithers <$> mapM checkQueue qs + forM_ qs' $ \rq@RcvQueue {connId} -> atomically $ do + modifyTVar (subscrConns c) $ S.insert connId RQ.addQueue rq $ pendingSubs c - case L.nonEmpty qs_ of - Just qs' -> do - mode <- sessionMode <$> readTVarIO (useNetworkConfig c) - -- TODO these subscriptions should happen in different sessions if mode is TSMEntity - -- it is also a question whether it is needed to group by server outside if grouping by sessions should happen here anyway - let userId = 1 - tSess = (userId, srv, Nothing) - smp_ <- tryError $ getSMPServerClient c tSess - (eitherToMaybe smp_,) . (errs <>) <$> case smp_ of - Left e -> pure $ map (,Left e) qs_ - Right smp -> do - logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB" - let qs2 = L.map queueCreds qs' - n = (length qs2 - 1) `div` 90 + 1 - liftIO $ incClientStatN c userId smp n "SUBS" "OK" - liftIO $ do - rs <- zip qs_ . L.toList <$> subscribeSMPQueues smp qs2 - mapM_ (uncurry $ processSubResult c) rs - pure $ map (second . first $ protocolClientError SMP $ clientServer smp) rs - _ -> pure (Nothing, errs) + (errs <>) <$> do + mode <- sessionMode <$> readTVarIO (useNetworkConfig c) + let sessRcvQs = foldl' (addRcvQueue mode) M.empty qs' + concat <$> mapConcurrently (fmap (L.toList . snd) . uncurry (subscribeQueues_ c)) (M.assocs sessRcvQs) + where + checkQueue rq@RcvQueue {rcvId, server} = do + prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c + pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq + addRcvQueue :: TransportSessionMode -> Map SMPTransportSession (NonEmpty RcvQueue) -> RcvQueue -> Map SMPTransportSession (NonEmpty RcvQueue) + addRcvQueue mode m rq@RcvQueue {userId, server, rcvId} = + let tSess = (userId, server, if mode == TSMEntity then Just rcvId else Nothing) + in M.alter (Just . maybe [rq] (rq <|)) tSess m + +-- | subscribe multiple queues - all passed queues should be on the same server +-- TODO check session? depends on how session mode change will be handled +subscribeQueues_ :: AgentMonad m => AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> m (Maybe SMPClient, NonEmpty (RcvQueue, Either AgentErrorType ())) +subscribeQueues_ c tSess@(userId, srv, _) qs = do + smp_ <- tryError $ getSMPServerClient c tSess + (eitherToMaybe smp_,) <$> case smp_ of + Left e -> pure $ L.map (,Left e) qs + Right smp -> do + logServer "-->" c srv (bshow (length qs) <> " queues") "SUB" + let qs2 = L.map queueCreds qs + n = (length qs2 - 1) `div` 90 + 1 + liftIO $ incClientStatN c userId smp n "SUBS" "OK" + liftIO $ do + rs <- L.zip qs <$> subscribeSMPQueues smp qs2 + mapM_ (uncurry $ processSubResult c) rs + pure $ L.map (second . first $ protocolClientError SMP $ clientServer smp) rs where - checkQueue rq@RcvQueue {rcvId, server} - | server == srv = do - prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c - pure $ if prohibited || srv /= server then Left (rq, Left $ CMD PROHIBITED) else Right rq - | otherwise = pure $ Left (rq, Left $ INTERNAL "queue server does not match parameter") queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId) addSubscription :: MonadIO m => AgentClient -> RcvQueue -> m () diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index 9ace32db7..e25c6a8ff 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs @@ -1,18 +1,30 @@ {-# LANGUAGE NamedFieldPuns #-} -module Simplex.Messaging.Agent.TRcvQueues where +module Simplex.Messaging.Agent.TRcvQueues + ( TRcvQueues, + empty, + clear, + deleteConn, + hasConn, + getConns, + addQueue, + deleteQueue, + getSessQueues, + getDelSessQueues, + ) +where import Control.Concurrent.STM import qualified Data.Map.Strict as M import Data.Set (Set) import qualified Data.Set as S import Simplex.Messaging.Agent.Protocol (ConnId) -import Simplex.Messaging.Agent.Store (RcvQueue (..)) +import Simplex.Messaging.Agent.Store (RcvQueue (..), UserId) import Simplex.Messaging.Protocol (RecipientId, SMPServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -newtype TRcvQueues = TRcvQueues (TMap (SMPServer, RecipientId) RcvQueue) +newtype TRcvQueues = TRcvQueues (TMap (UserId, SMPServer, RecipientId) RcvQueue) empty :: STM TRcvQueues empty = TRcvQueues <$> TM.empty @@ -30,19 +42,26 @@ getConns :: TRcvQueues -> STM (Set ConnId) getConns (TRcvQueues qs) = M.foldr' (S.insert . connId) S.empty <$> readTVar qs addQueue :: RcvQueue -> TRcvQueues -> STM () -addQueue rq@RcvQueue {server, rcvId} (TRcvQueues qs) = TM.insert (server, rcvId) rq qs +addQueue rq (TRcvQueues qs) = TM.insert (qKey rq) rq qs deleteQueue :: RcvQueue -> TRcvQueues -> STM () -deleteQueue RcvQueue {server, rcvId} (TRcvQueues qs) = TM.delete (server, rcvId) qs +deleteQueue rq (TRcvQueues qs) = TM.delete (qKey rq) qs -getSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue] -getSrvQueues srv (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs +getSessQueues :: (UserId, SMPServer, Maybe RecipientId) -> TRcvQueues -> STM [RcvQueue] +getSessQueues tSess (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs where - addQ qs' rq@RcvQueue {server} = if srv == server then rq : qs' else qs' + addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs' -getDelSrvQueues :: SMPServer -> TRcvQueues -> STM ([RcvQueue], Set ConnId) -getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ (([], S.empty), M.empty) +getDelSessQueues :: (UserId, SMPServer, Maybe RecipientId) -> TRcvQueues -> STM ([RcvQueue], Set ConnId) +getDelSessQueues tSess (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ (([], S.empty), M.empty) where - addQ (removed@(remQs, remConns), qs') rq@RcvQueue {connId, server, rcvId} - | srv == server = ((rq : remQs, S.insert connId remConns), qs') - | otherwise = (removed, M.insert (server, rcvId) rq qs') + addQ (removed@(remQs, remConns), qs') rq@RcvQueue {connId} + | rq `isSession` tSess = ((rq : remQs, S.insert connId remConns), qs') + | otherwise = (removed, M.insert (qKey rq) rq qs') + +isSession :: RcvQueue -> (UserId, SMPServer, Maybe RecipientId) -> Bool +isSession RcvQueue {userId, server, rcvId} (uId, srv, qId_) = + userId == uId && server == srv && maybe True (rcvId ==) qId_ + +qKey :: RcvQueue -> (UserId, SMPServer, RecipientId) +qKey RcvQueue {userId, server, rcvId} = (userId, server, rcvId) From b549910c17450132f3fb8067dda543045b7e5e3d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 16 Jan 2023 08:51:41 +0000 Subject: [PATCH 04/19] support switching session mode, transport session now uses connection ID (#607) * support switching session mode, transport session now uses connection ID * refactor --- src/Simplex/Messaging/Agent.hs | 26 +++---- src/Simplex/Messaging/Agent/Client.hs | 59 +++++++-------- src/Simplex/Messaging/Agent/TRcvQueues.hs | 14 ++-- tests/AgentTests.hs | 4 +- tests/AgentTests/FunctionalAPITests.hs | 90 ++++++++++++++++++++--- 5 files changed, 128 insertions(+), 65 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 1074d9abd..67edbd458 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -386,13 +386,17 @@ deleteUser' c userId = do newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId newConnAsync c userId corrId enableNtfs cMode = do - g <- asks idsDrg - connAgentVersion <- asks $ maxVersion . smpAgentVRange . config - let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent - connId <- withStore c $ \db -> createNewConn db g cData cMode + connId <- newConnNoQueues c userId "" enableNtfs cMode enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pure connId +newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> m ConnId +newConnNoQueues c userId connId enableNtfs cMode = do + g <- asks idsDrg + connAgentVersion <- asks $ maxVersion . smpAgentVRange . config + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent + withStore c $ \db -> createNewConn db g cData cMode + joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo = do aVRange <- asks $ smpAgentVRange . config @@ -473,9 +477,9 @@ newConn c userId connId asyncMode enableNtfs cMode clientData = newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) newConnSrv c userId connId asyncMode enableNtfs cMode clientData srv = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - (q, qUri) <- newRcvQueue c userId "" srv smpClientVRange - connId' <- setUpConn asyncMode q $ maxVersion smpAgentVRange - let rq = (q :: RcvQueue) {connId = connId'} + connId' <- if asyncMode then pure connId else newConnNoQueues c userId connId enableNtfs cMode + (rq, qUri) <- newRcvQueue c userId connId' srv smpClientVRange `catchError` \e -> liftIO (print e) >> throwError e + void . withStore c $ \db -> updateNewConnRcv db connId' rq addSubscription c rq when enableNtfs $ do ns <- asks ntfSupervisor @@ -487,14 +491,6 @@ newConnSrv c userId connId asyncMode enableNtfs cMode clientData srv = do (pk1, pk2, e2eRcvParams) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange withStore' c $ \db -> createRatchetX3dhKeys db connId' pk1 pk2 pure (connId', CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) - where - setUpConn True rq _ = do - void . withStore c $ \db -> updateNewConnRcv db connId rq - pure connId - setUpConn False rq connAgentVersion = do - g <- asks idsDrg - let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent - withStore c $ \db -> createRcvConn db g cData rq cMode joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId joinConn c userId connId asyncMode enableNtfs cReq cInfo = do diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 1b152b87f..6efbb8b0d 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -99,7 +99,7 @@ import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Either (isRight, partitionEithers) +import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.List (foldl', partition) import Data.List.NonEmpty (NonEmpty (..), (<|)) @@ -352,17 +352,10 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, where resubscribe :: NonEmpty RcvQueue -> m () resubscribe qs = do - connected <- maybe False isRight <$> atomically (TM.lookup tSess smpClients $>>= tryReadTMVar) cs <- atomically . RQ.getConns $ activeSubs c - -- TODO the unsolved problem is changing session mode - -- currently it would reconnect the same client and will keep it around, until the app is restarted. - -- instead it should check whether session mode changed and connect somehow differently if it did... - (client_, rs) <- subscribeQueues_ c tSess qs - let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) $ L.toList rs + rs <- subscribeQueues c $ L.toList qs + let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs liftIO $ do - unless connected . forM_ client_ $ \cl -> do - incClientStat c userId cl "CONNECT" "" - notifySub "" $ hostEvent CONNECT cl let conns = S.toList $ S.fromList okConns `S.difference` cs unless (null conns) $ notifySub "" $ UP srv conns let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs @@ -610,12 +603,19 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do testErr step = SMPTestFailure step . protocolClientError SMP addr mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg) -mkTransportSession c userId srv entityId = do - mode <- sessionMode <$> readTVarIO (useNetworkConfig c) - pure (userId, srv, if mode == TSMEntity then Just entityId else Nothing) +mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c + +mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg +mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing) mkSMPTransportSession :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession -mkSMPTransportSession c q = mkTransportSession c (qUserId q) (qServer q) (queueId q) +mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c + +mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession +mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q) + +getSessionMode :: AgentMonad m => AgentClient -> m TransportSessionMode +getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri) newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do @@ -684,7 +684,7 @@ temporaryOrHostError = \case BROKER _ HOST -> True e -> temporaryAgentError e -subscribeQueues :: AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())] +subscribeQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())] subscribeQueues c qs = do (errs, qs') <- partitionEithers <$> mapM checkQueue qs forM_ qs' $ \rq@RcvQueue {connId} -> atomically $ do @@ -693,32 +693,27 @@ subscribeQueues c qs = do (errs <>) <$> do mode <- sessionMode <$> readTVarIO (useNetworkConfig c) let sessRcvQs = foldl' (addRcvQueue mode) M.empty qs' - concat <$> mapConcurrently (fmap (L.toList . snd) . uncurry (subscribeQueues_ c)) (M.assocs sessRcvQs) + concat <$> mapConcurrently (fmap L.toList . uncurry (subscribeQueues_ c)) (M.assocs sessRcvQs) where checkQueue rq@RcvQueue {rcvId, server} = do prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq addRcvQueue :: TransportSessionMode -> Map SMPTransportSession (NonEmpty RcvQueue) -> RcvQueue -> Map SMPTransportSession (NonEmpty RcvQueue) - addRcvQueue mode m rq@RcvQueue {userId, server, rcvId} = - let tSess = (userId, server, if mode == TSMEntity then Just rcvId else Nothing) + addRcvQueue mode m rq = + let tSess = mkSMPTSession rq mode in M.alter (Just . maybe [rq] (rq <|)) tSess m --- | subscribe multiple queues - all passed queues should be on the same server --- TODO check session? depends on how session mode change will be handled -subscribeQueues_ :: AgentMonad m => AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> m (Maybe SMPClient, NonEmpty (RcvQueue, Either AgentErrorType ())) -subscribeQueues_ c tSess@(userId, srv, _) qs = do - smp_ <- tryError $ getSMPServerClient c tSess - (eitherToMaybe smp_,) <$> case smp_ of +subscribeQueues_ :: AgentMonad m => AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> m (NonEmpty (RcvQueue, Either AgentErrorType ())) +subscribeQueues_ c tSess@(userId, srv, _) qs = + tryError (getSMPServerClient c tSess) >>= \case Left e -> pure $ L.map (,Left e) qs - Right smp -> do + Right smp -> liftIO $ do logServer "-->" c srv (bshow (length qs) <> " queues") "SUB" - let qs2 = L.map queueCreds qs - n = (length qs2 - 1) `div` 90 + 1 - liftIO $ incClientStatN c userId smp n "SUBS" "OK" - liftIO $ do - rs <- L.zip qs <$> subscribeSMPQueues smp qs2 - mapM_ (uncurry $ processSubResult c) rs - pure $ L.map (second . first $ protocolClientError SMP $ clientServer smp) rs + let n = (length qs - 1) `div` 90 + 1 + incClientStatN c userId smp n "SUBS" "OK" + rs <- L.zip qs <$> subscribeSMPQueues smp (L.map queueCreds qs) + mapM_ (uncurry $ processSubResult c) rs + pure $ L.map (second . first $ protocolClientError SMP $ clientServer smp) rs where queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId) diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index e25c6a8ff..ff525d4bb 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs @@ -47,21 +47,21 @@ addQueue rq (TRcvQueues qs) = TM.insert (qKey rq) rq qs deleteQueue :: RcvQueue -> TRcvQueues -> STM () deleteQueue rq (TRcvQueues qs) = TM.delete (qKey rq) qs -getSessQueues :: (UserId, SMPServer, Maybe RecipientId) -> TRcvQueues -> STM [RcvQueue] +getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue] getSessQueues tSess (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs where addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs' -getDelSessQueues :: (UserId, SMPServer, Maybe RecipientId) -> TRcvQueues -> STM ([RcvQueue], Set ConnId) +getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM ([RcvQueue], Set ConnId) getDelSessQueues tSess (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ (([], S.empty), M.empty) where addQ (removed@(remQs, remConns), qs') rq@RcvQueue {connId} | rq `isSession` tSess = ((rq : remQs, S.insert connId remConns), qs') | otherwise = (removed, M.insert (qKey rq) rq qs') -isSession :: RcvQueue -> (UserId, SMPServer, Maybe RecipientId) -> Bool -isSession RcvQueue {userId, server, rcvId} (uId, srv, qId_) = - userId == uId && server == srv && maybe True (rcvId ==) qId_ +isSession :: RcvQueue -> (UserId, SMPServer, Maybe ConnId) -> Bool +isSession rq (uId, srv, connId_) = + userId rq == uId && server rq == srv && maybe True (connId rq ==) connId_ -qKey :: RcvQueue -> (UserId, SMPServer, RecipientId) -qKey RcvQueue {userId, server, rcvId} = (userId, server, rcvId) +qKey :: RcvQueue -> (UserId, SMPServer, ConnId) +qKey rq = (userId rq, server rq, connId rq) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index bdc3a28d0..3c6bfa696 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -381,8 +381,8 @@ testMsgDeliveryAgentRestart t bob = do (corrId == "3" && cmd == OK) || (corrId == "" && cmd == SENT 5) _ -> False - bob <# ("", "", UP server ["alice"]) - bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False + bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False + bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK) removeFile testStoreLogFile diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index fc780ad1f..989d65230 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -26,7 +26,7 @@ where import Control.Concurrent (killThread, threadDelay) import Control.Monad -import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT) +import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.IO.Unlift import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -41,7 +41,8 @@ import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig) +import Simplex.Messaging.Agent.Store (UserId) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..)) import qualified Simplex.Messaging.Protocol as SMP @@ -183,6 +184,9 @@ functionalAPITests t = do describe "getRatchetAdHash" $ it "should return the same data for both peers" $ withSmpServer t testRatchetAdHash + describe "multiple users" $ + it "should connect two users and switch session mode" $ + withSmpServer t testTwoUsers testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do @@ -446,9 +450,12 @@ testDuplicateMessage t = do get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) -makeConnection alice bob = do - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" +makeConnection alice bob = makeConnectionForUsers alice 1 bob 1 + +makeConnectionForUsers :: AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) +makeConnectionForUsers alice aliceUserId bob bobUserId = do + (bobId, qInfo) <- createConnection alice aliceUserId True SCMInvitation Nothing + aliceId <- joinConnection bob bobUserId True qInfo "bob's connInfo" ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -536,10 +543,8 @@ testSuspendingAgentCompleteSending t = do get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False ("", "", SUSPENDED) <- get b - r <- get a - liftIO $ print r - ("", "", UP {}) <- pure r - get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False + get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False + get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False ackMessage a bId 5 get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False ackMessage a bId 6 @@ -831,6 +836,73 @@ testRatchetAdHash = do ad2 <- getConnectionRatchetAdHash b aId liftIO $ ad1 `shouldBe` ad2 +testTwoUsers :: IO () +testTwoUsers = do + let nc = netCfg initAgentServers + a <- getSMPAgentClient agentCfg initAgentServers + b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers + sessionMode nc `shouldBe` TSMUser + runRight_ $ do + (aId1, bId1) <- makeConnectionForUsers a 1 b 1 + exchangeGreetings a bId1 b aId1 + (aId1', bId1') <- makeConnectionForUsers a 1 b 1 + exchangeGreetings a bId1' b aId1' + a `hasClients` 1 + b `hasClients` 1 + setNetworkConfig a nc {sessionMode = TSMEntity} + liftIO $ threadDelay 250000 + ("", "", DOWN _ _) <- get a + ("", "", UP _ _) <- get a + a `hasClients` 2 + + exchangeGreetingsMsgId 6 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId1' b aId1' + liftIO $ threadDelay 250000 + setNetworkConfig a nc {sessionMode = TSMUser} + liftIO $ threadDelay 250000 + ("", "", DOWN _ _) <- get a + ("", "", DOWN _ _) <- get a + ("", "", UP _ _) <- get a + ("", "", UP _ _) <- get a + a `hasClients` 1 + + aUserId2 <- createUser a [noAuthSrv testSMPServer] + (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1 + exchangeGreetings a bId2 b aId2 + (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1 + exchangeGreetings a bId2' b aId2' + a `hasClients` 2 + b `hasClients` 1 + setNetworkConfig a nc {sessionMode = TSMEntity} + liftIO $ threadDelay 250000 + ("", "", DOWN _ _) <- get a + ("", "", DOWN _ _) <- get a + ("", "", UP _ _) <- get a + ("", "", UP _ _) <- get a + a `hasClients` 4 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId1' b aId1' + exchangeGreetingsMsgId 6 a bId2 b aId2 + exchangeGreetingsMsgId 6 a bId2' b aId2' + liftIO $ threadDelay 250000 + setNetworkConfig a nc {sessionMode = TSMUser} + liftIO $ threadDelay 250000 + ("", "", DOWN _ _) <- get a + ("", "", DOWN _ _) <- get a + ("", "", DOWN _ _) <- get a + ("", "", DOWN _ _) <- get a + ("", "", UP _ _) <- get a + ("", "", UP _ _) <- get a + ("", "", UP _ _) <- get a + ("", "", UP _ _) <- get a + a `hasClients` 2 + exchangeGreetingsMsgId 10 a bId1 b aId1 + exchangeGreetingsMsgId 10 a bId1' b aId1' + exchangeGreetingsMsgId 8 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId2' b aId2' + where + hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n + exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () exchangeGreetings = exchangeGreetingsMsgId 4 From 324e01300dc9e5f3d1372c10f8d6b6df0cfe0bf8 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 16 Jan 2023 11:06:19 +0000 Subject: [PATCH 05/19] execute asynchronous commands for correct users, include session in messages from SMP clients to agent (#608) * execute asynchronous commands for correct users * pass transport session to message processing to avoid race condition * account for server changes when determining unused servers * enable one test * enable all tests, remove log --- src/Simplex/Messaging/Agent.hs | 59 +++++++++---------- src/Simplex/Messaging/Agent/Client.hs | 17 ++---- src/Simplex/Messaging/Agent/Store.hs | 7 +++ src/Simplex/Messaging/Agent/Store/SQLite.hs | 13 +++- .../SQLite/Migrations/M20230110_users.hs | 2 + .../Store/SQLite/Migrations/agent_schema.sql | 1 + src/Simplex/Messaging/Client.hs | 37 ++++++++---- src/Simplex/Messaging/Client/Agent.hs | 2 +- src/Simplex/Messaging/Notifications/Server.hs | 2 +- src/Simplex/Messaging/Protocol.hs | 2 +- tests/AgentTests.hs | 4 +- tests/AgentTests/FunctionalAPITests.hs | 2 +- 12 files changed, 85 insertions(+), 63 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 67edbd458..f5747e51c 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -99,7 +99,7 @@ import qualified Data.ByteString.Char8 as B import Data.Composition ((.:), (.:.), (.::)) import Data.Foldable (foldl') import Data.Functor (($>)) -import Data.List (deleteFirstsBy, find) +import Data.List (deleteFirstsBy, find, (\\)) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -126,7 +126,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, sameSrvAddr, sameSrvAddr') +import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr, sameSrvAddr') import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util @@ -196,7 +196,7 @@ deleteConnectionAsync c = withAgentEnv c .: deleteConnectionAsync' c -- | Create SMP agent connection (NEW command) createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) -createConnection c userId enableNtfs cMode clientData = withAgentEnv c $ newConn c userId "" False enableNtfs cMode clientData +createConnection c userId enableNtfs cMode clientData = withAgentEnv c $ newConn c userId "" enableNtfs cMode clientData -- | Join SMP agent connection (JOIN command) joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId @@ -357,7 +357,7 @@ client c@AgentClient {rcvQ, subQ} = forever $ do -- | execute any SMP agent command processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent) processCommand c (connId, cmd) = case cmd of - NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId False enableNtfs cMode Nothing + NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK) ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo @@ -470,27 +470,31 @@ switchConnectionAsync' c corrId connId = SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand SWCH _ -> throwError $ CMD PROHIBITED -newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) -newConn c userId connId asyncMode enableNtfs cMode clientData = - getSMPServer c userId >>= newConnSrv c userId connId asyncMode enableNtfs cMode clientData +newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) +newConn c userId connId enableNtfs cMode clientData = + getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData -newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) -newConnSrv c userId connId asyncMode enableNtfs cMode clientData srv = do +newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) +newConnSrv c userId connId enableNtfs cMode clientData srv = do + connId' <- newConnNoQueues c userId connId enableNtfs cMode + newRcvConnSrv c userId connId' enableNtfs cMode clientData srv + +newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) +newRcvConnSrv c userId connId enableNtfs cMode clientData srv = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - connId' <- if asyncMode then pure connId else newConnNoQueues c userId connId enableNtfs cMode - (rq, qUri) <- newRcvQueue c userId connId' srv smpClientVRange `catchError` \e -> liftIO (print e) >> throwError e - void . withStore c $ \db -> updateNewConnRcv db connId' rq + (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange `catchError` \e -> liftIO (print e) >> throwError e + void . withStore c $ \db -> updateNewConnRcv db connId rq addSubscription c rq when enableNtfs $ do ns <- asks ntfSupervisor - atomically $ sendNtfSubCommand ns (connId', NSCCreate) + atomically $ sendNtfSubCommand ns (connId, NSCCreate) let crData = ConnReqUriData simplexChat smpAgentVRange [qUri] clientData case cMode of - SCMContact -> pure (connId', CRContactUri crData) + SCMContact -> pure (connId, CRContactUri crData) SCMInvitation -> do (pk1, pk2, e2eRcvParams) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange - withStore' c $ \db -> createRatchetX3dhKeys db connId' pk1 pk2 - pure (connId', CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) + withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 + pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId joinConn c userId connId asyncMode enableNtfs cReq cInfo = do @@ -545,7 +549,7 @@ joinConnSrv c userId connId False enableNtfs (CRContactUri ConnReqUriData {crAge crAgentVRange `compatibleVersion` aVRange ) of (Just qInfo, Just vrsn) -> do - (connId', cReq) <- newConnSrv c userId connId False enableNtfs SCMInvitation Nothing srv + (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing srv sendInvitation c userId qInfo vrsn cReq cInfo pure connId' _ -> throwError $ AGENT A_VERSION @@ -804,22 +808,20 @@ runCommandProcessing c@AgentClient {subQ} server_ = do atomically $ beginAgentOperation c AOSndNetwork E.try (withStore c $ \db -> getPendingCommand db cmdId) >>= \case Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", ERR . INTERNAL $ show e) - Right (corrId, connId, cmd) -> processCmd (riFast ri) corrId connId cmdId cmd + Right cmd -> processCmd (riFast ri) cmdId cmd where - processCmd :: RetryInterval -> ACorrId -> ConnId -> AsyncCmdId -> AgentCommand -> m () - processCmd ri corrId connId cmdId command = case command of + processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m () + processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of AClientCommand cmd -> case cmd of NEW enableNtfs (ACM cMode) -> noServer $ do usedSrvs <- newTVarIO ([] :: [SMPServer]) tryCommand . withNextSrv usedSrvs [] $ \srv -> do - let userId = 1 -- TODO - (_, cReq) <- newConnSrv c userId connId True enableNtfs cMode Nothing srv + (_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing srv notify $ INV (ACR cMode cReq) JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) connInfo -> noServer $ do let initUsed = [qServer q] usedSrvs <- newTVarIO initUsed tryCommand . withNextSrv usedSrvs initUsed $ \srv -> do - let userId = 1 -- TODO void $ joinConnSrv c userId connId True enableNtfs cReq connInfo srv notify OK LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK @@ -916,12 +918,11 @@ runCommandProcessing c@AgentClient {subQ} server_ = do withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m () withNextSrv usedSrvs initUsed action = do used <- readTVarIO usedSrvs - let userId = 1 -- TODO srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId used atomically $ do srvs_ <- TM.lookup userId $ smpServers c - -- TODO this condition does not account for servers change, it has to be changed to see if there are any remaining unused servers configured for the user - let used' = if length used + 1 >= maybe 0 L.length srvs_ then initUsed else srv : used + let unused = maybe [] ((\\ used) . map protoServer . L.toList) srvs_ + used' = if null unused then initUsed else srv : used writeTVar usedSrvs $! used' action srvAuth -- ^ ^ ^ async command processing / @@ -1505,7 +1506,7 @@ subscriber c@AgentClient {msgQ} = forever $ do Right _ -> return () processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m () -processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cmd) = do +processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do (rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId) processSMP rq conn $ connData conn where @@ -1608,9 +1609,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm ackDel = enqueueCmd . ICAckDel rId srvMsgId handleNotifyAck :: m () -> m () handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack - SMP.END -> do - -- TODO is race condition possible here on session mode change? - tSess <- mkSMPTransportSession c rq + SMP.END -> atomically (TM.lookup tSess smpClients $>>= tryReadTMVar >>= processEND) >>= logServer "<--" c srv rId where diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 6efbb8b0d..641b7e86e 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -48,9 +48,6 @@ module Simplex.Messaging.Agent.Client agentNtfCreateSubscription, agentNtfCheckSubscription, agentNtfDeleteSubscription, - -- TODO possibly, this should not be exported? - -- this is used in END processing - mkSMPTransportSession, agentCbEncrypt, agentCbDecrypt, cryptoError, @@ -170,9 +167,6 @@ type SMPClientVar = TMVar (Either AgentErrorType SMPClient) type NtfClientVar = TMVar (Either AgentErrorType NtfClient) --- | Transport session key - includes entity ID if `sessionMode = TSMEntity`. -type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) - type SMPTransportSession = TransportSession SMP.BrokerMsg type NtfTransportSession = TransportSession NtfResponse @@ -299,7 +293,7 @@ instance ProtocolServerClient NtfResponse where clientProtocolError = NTF getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient -getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, entityId_) = do +getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped" atomically (getClientVar tSess smpClients) >>= either @@ -310,8 +304,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, connectClient = do cfg <- getClientConfig c smpCfg u <- askUnliftIO - let proxyUsername = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_ - liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient srv cfg (Just proxyUsername) (Just msgQ) $ clientDisconnected u) + liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg (Just msgQ) $ clientDisconnected u) clientDisconnected :: UnliftIO m -> SMPClient -> IO () clientDisconnected u client = do @@ -376,7 +369,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d connectClient :: m NtfClient connectClient = do cfg <- getClientConfig c ntfCfg - liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient srv cfg Nothing Nothing clientDisconnected) + liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing clientDisconnected) clientDisconnected :: NtfClient -> IO () clientDisconnected client = do @@ -583,8 +576,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.SignAlg a <- asks $ cmdSignAlg . config liftIO $ do - let proxyUsername = C.sha256Hash $ bshow userId - getProtocolClient srv cfg (Just proxyUsername) Nothing (\_ -> pure ()) >>= \case + let tSess = (userId, srv, Nothing) + getProtocolClient tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do (rKey, rpKey) <- C.generateSignatureKeyPair a (sKey, _) <- C.generateSignatureKeyPair a diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index cff4ca125..7f9f8bb90 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -254,6 +254,13 @@ data ConnData = ConnData } deriving (Eq, Show) +data PendingCommand = PendingCommand + { corrId :: ACorrId, + userId :: UserId, + connId :: ConnId, + command :: AgentCommand + } + data AgentCmdType = ACClient | ACInternal type UserId = Int64 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index dfdc73103..59e6b41e2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -836,13 +836,20 @@ getPendingCommands db connId = do where srvCmdId (host, port, keyHash, cmdId) = (SMPServer <$> host <*> port <*> keyHash, cmdId) -getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError (ACorrId, ConnId, AgentCommand)) +getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError PendingCommand) getPendingCommand db msgId = do - firstRow id SECmdNotFound $ + firstRow pendingCommand SECmdNotFound $ DB.query db - "SELECT corr_id, conn_id, command FROM commands WHERE command_id = ?" + [sql| + SELECT c.corr_id, cs.user_id, c.conn_id, c.command + FROM commands c + JOIN connections cs USING (conn_id) + WHERE c.command_id = ? + |] (Only msgId) + where + pendingCommand (corrId, userId, connId, command) = PendingCommand {corrId, userId, connId, command} deleteCommand :: DB.Connection -> AsyncCmdId -> IO () deleteCommand db cmdId = diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs index a56930ad0..73758cdeb 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs @@ -21,6 +21,8 @@ REFERENCES users ON DELETE CASCADE; CREATE INDEX idx_connections_user ON connections(user_id); +CREATE INDEX idx_commands_conn_id ON commands(conn_id); + UPDATE connections SET user_id = 1; PRAGMA ignore_check_constraints=OFF; diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 548aaa63c..3121dd736 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -232,3 +232,4 @@ CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries( ); CREATE TABLE users(user_id INTEGER PRIMARY KEY AUTOINCREMENT); CREATE INDEX idx_connections_user ON connections(user_id); +CREATE INDEX idx_commands_conn_id ON commands(conn_id); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index dcf1e3e10..5f67bcc95 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -26,6 +26,7 @@ -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md module Simplex.Messaging.Client ( -- * Connect (disconnect) client to (from) SMP server + TransportSession, ProtocolClient (thVersion, sessionId, sessionTs), SMPClient, getProtocolClient, @@ -76,6 +77,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (rights) import Data.Functor (($>)) +import Data.Int (Int64) import Data.List (find) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -111,7 +113,7 @@ data ProtocolClient msg = ProtocolClient data PClient msg = PClient { connected :: TVar Bool, - protocolServer :: ProtoServer msg, + transportSession :: TransportSession msg, transportHost :: TransportHost, tcpTimeout :: Int, clientCorrId :: TVar Natural, @@ -127,7 +129,7 @@ type SMPClient = ProtocolClient SMP.BrokerMsg type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg) -- | Type synonym for transmission from some SPM server queue. -type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg) +type ServerTransmission msg = (TransportSession msg, Version, SessionId, QueueId, msg) data HostMode = -- | prefer (or require) onion hosts when connecting via SOCKS proxy @@ -243,19 +245,26 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts publicHost = find (not . isOnionHost) hosts clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient msg -> String -clientServer = B.unpack . strEncode . protocolServer . client_ +clientServer = B.unpack . strEncode . snd3 . transportSession . client_ + where + snd3 (_, s, _) = s transportHost' :: ProtocolClient msg -> TransportHost transportHost' = transportHost . client_ +type UserId = Int64 + +-- | Transport session key - includes entity ID if `sessionMode = TSMEntity`. +type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) + -- | Connects to 'ProtocolServer' using passed client configuration -- and queue for messages and notifications. -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe ByteString -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg)) -getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} proxyUsername msgQ disconnected = do - case chooseTransportHost networkConfig (host protocolServer) of +getProtocolClient :: forall msg. Protocol msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg)) +getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do + case chooseTransportHost networkConfig (host srv) of Right useHost -> (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost) `catch` \(e :: IOException) -> pure . Left $ PCEIOError e @@ -272,7 +281,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, return PClient { connected, - protocolServer, + transportSession, transportHost, tcpTimeout, clientCorrId, @@ -286,9 +295,10 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, runClient (port', ATransport t) useHost c = do cVar <- newEmptyTMVarIO let tcConfig = transportClientConfig networkConfig + username = proxyUsername transportSession action <- async $ - runTransportClient tcConfig proxyUsername useHost port' (Just $ keyHash protocolServer) (client t c cVar) + runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar) `finally` atomically (putTMVar cVar $ Left PCENetworkError) c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar) pure $ case c_ of @@ -296,15 +306,18 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, Just (Left e) -> Left e Nothing -> Left PCENetworkError + proxyUsername :: TransportSession msg -> ByteString + proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_ + useTransport :: (ServiceName, ATransport) - useTransport = case port protocolServer of + useTransport = case port srv of "" -> defaultTransport cfg "80" -> ("80", transport @WS) p -> (p, transport @TLS) client :: forall c. Transport c => TProxy c -> PClient msg -> TMVar (Either ProtocolClientError (ProtocolClient msg)) -> c -> IO () client _ c cVar h = - runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case + runExceptT (protocolClientHandshake @msg h (keyHash srv) smpServerVRange) >>= \case Left e -> atomically . putTMVar cVar . Left $ PCETransportError e Right th@THandle {sessionId, thVersion} -> do sessionTs <- getCurrentTime @@ -426,8 +439,8 @@ writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO () writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c) serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg -serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {protocolServer}} entityId message = - (protocolServer, thVersion, sessionId, entityId, message) +serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {transportSession}} entityId message = + (transportSession, thVersion, sessionId, entityId, message) -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue -- diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index f2fe97666..feefacecd 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -160,7 +160,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = void $ tryConnectClient (const reconnectClient) loop connectClient :: ExceptT ProtocolClientError IO SMPClient - connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) Nothing (Just msgQ) clientDisconnected + connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected clientDisconnected :: SMPClient -> IO () clientDisconnected _ = do diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 80069a534..02f07da00 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -190,7 +190,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge receiveSMP :: M () receiveSMP = forever $ do - (srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ + ((_, srv, _), _, _, ntfId, msg) <- atomically $ readTBQueue msgQ let smpQueue = SMPQueueNtf srv ntfId case msg of SMP.NMSG nmsgNonce encNMsgMeta -> do diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index a6897074d..59643f6b4 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -746,7 +746,7 @@ basicAuth s where valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/' -data ProtoServerWithAuth p = ProtoServerWithAuth (ProtocolServer p) (Maybe BasicAuth) +data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer p, serverBasicAuth :: Maybe BasicAuth} deriving (Show) instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 3c6bfa696..705bf4550 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -338,8 +338,8 @@ testServerConnectionAfterError t _ = do withServer $ do alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False - bob <# ("", "", UP server ["alice"]) - bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False + bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False + bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK) alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5) alice <# ("", "bob", SENT 5) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 989d65230..6109b85f4 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -156,7 +156,7 @@ functionalAPITests t = do it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 1 it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "wrong", 5) `shouldReturn` 1 it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 4) `shouldReturn` 1 - describe "no server auth" $ do + fdescribe "no server auth" $ do it "success " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 2 it "srv disabled" $ testBasicAuth t False (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 0 it "version srv " $ testBasicAuth t True (Nothing, 4) (Nothing, 5) (Nothing, 5) `shouldReturn` 2 From 42df6a421d3e0865b96f849423f5eddf0f692653 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Tue, 17 Jan 2023 16:07:13 +0400 Subject: [PATCH 06/19] add missing fkey indexes (#610) --- simplexmq.cabal | 1 + .../Agent/Store/SQLite/Migrations.hs | 4 +- .../Migrations/M20230117_fkey_indexes.hs | 27 ++++++++++++ .../Store/SQLite/Migrations/agent_schema.sql | 41 +++++++++++++++++++ tests/AgentTests/FunctionalAPITests.hs | 2 +- 5 files changed, 73 insertions(+), 2 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230117_fkey_indexes.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index cda50b68b..14fdf79ad 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -56,6 +56,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 386a0eab1..994f16590 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -38,6 +38,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport.Client (TransportHost) @@ -55,7 +56,8 @@ schemaMigrations = ("m20220817_connection_ntfs", m20220817_connection_ntfs), ("m20220905_commands", m20220905_commands), ("m20220915_connection_queues", m20220915_connection_queues), - ("m20230110_users", m20230110_users) + ("m20230110_users", m20230110_users), + ("m20230117_fkey_indexes", m20230117_fkey_indexes) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230117_fkey_indexes.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230117_fkey_indexes.hs new file mode 100644 index 000000000..c0f2ac5b4 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230117_fkey_indexes.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- .lint fkey-indexes +m20230117_fkey_indexes :: Query +m20230117_fkey_indexes = + [sql| +CREATE INDEX idx_commands_host_port ON commands(host, port); +CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id); +CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations(contact_conn_id); +CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages(conn_id, internal_snd_id); +CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages(conn_id, internal_rcv_id); +CREATE INDEX idx_messages_conn_id ON messages(conn_id); +CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions(ntf_host, ntf_port); +CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions(smp_host, smp_port); +CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens(ntf_host, ntf_port); +CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id); +CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages(conn_id, internal_id); +CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id); +CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries(conn_id, internal_id); +CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(conn_id, internal_id); +CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port); +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 3121dd736..9f1c50e9f 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -233,3 +233,44 @@ CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries( CREATE TABLE users(user_id INTEGER PRIMARY KEY AUTOINCREMENT); CREATE INDEX idx_connections_user ON connections(user_id); CREATE INDEX idx_commands_conn_id ON commands(conn_id); +CREATE INDEX idx_commands_host_port ON commands(host, port); +CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id); +CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations( + contact_conn_id +); +CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages( + conn_id, + internal_snd_id +); +CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages( + conn_id, + internal_rcv_id +); +CREATE INDEX idx_messages_conn_id ON messages(conn_id); +CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions( + ntf_host, + ntf_port +); +CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions( + smp_host, + smp_port +); +CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens( + ntf_host, + ntf_port +); +CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id); +CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages( + conn_id, + internal_id +); +CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id); +CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries( + conn_id, + internal_id +); +CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages( + conn_id, + internal_id +); +CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port); diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 6109b85f4..989d65230 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -156,7 +156,7 @@ functionalAPITests t = do it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 1 it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "wrong", 5) `shouldReturn` 1 it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 4) `shouldReturn` 1 - fdescribe "no server auth" $ do + describe "no server auth" $ do it "success " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 2 it "srv disabled" $ testBasicAuth t False (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 0 it "version srv " $ testBasicAuth t True (Nothing, 4) (Nothing, 5) (Nothing, 5) `shouldReturn` 2 From 0af6533510f3266cd9410ddb51af0039af7e4269 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 17 Jan 2023 12:24:05 +0000 Subject: [PATCH 07/19] rfc: update xftp doc (#609) --- rfcs/2022-12-26-simplex-file-transfer.md | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/rfcs/2022-12-26-simplex-file-transfer.md b/rfcs/2022-12-26-simplex-file-transfer.md index d3acf74c8..a607726fb 100644 --- a/rfcs/2022-12-26-simplex-file-transfer.md +++ b/rfcs/2022-12-26-simplex-file-transfer.md @@ -95,10 +95,12 @@ To send the file, the sender will: - compute SHA512 digest - pad the file to match the whole number of chunks in size, -- encrypt it with a randomly chosen symmetric key and IV (e.g., using NaCL cryptobox), +- encrypt it with a randomly chosen symmetric key and IV (e.g., using NaCL crypto_secretbox), - split into fixed size chunks - upload each chunk to a randomly chosen server. +The sending client should generate more per-recipient keys than the actual number of recipients, possibly rounding up to a power of 2, to conceal the actual number of intended recipients. + Then the sending client will combine addresses of all chunks and other information into "file description", different for each file recipient, that will include: - an encryption key that was used to encrypt the file (the same for all recipients). @@ -106,22 +108,24 @@ Then the sending client will combine addresses of all chunks and other informati - list of chunk descriptions; information for each chunk: - private Ed25519 key to sign commands for file transfer server. - chunk address (server host and chunk ID). + - chunk sha512 digest To reduce the size, chunk descriptions will be grouped by the server host. -This "file description" itself will be sent as a small file. To estimate its size: +This "file description" itself will be sent as a small file over an authenticated channel, to prevent file description modification. To estimate its size: - each chunk \* redundancy per chunk, assuming chunks are grouped per server: - - chunk number in the file - 8 bytes (including any overhead) + - 1-based chunk number in the file - 8 bytes (including any overhead) - Ed25519 key (different for each recipient / chunk combination) - 32 bytes \* 4/3 (base64, assuming text encoding) - chunk ID (different for each recipient) - 64 bytes \* 4/3 + - optional (only in the first chunk occurence) chunk sha512 digests - 64 bytes \* 4/3 - server addresses - say, 128 bytes per server - sha512 digest - 64 bytes \* 4/3 - encryption key - 32 bytes \* 4/3 - IV - 32 bytes \* 4/3 - encoding overhead - say, 256 bytes -For 1gb file, sent via 4 different servers, in 8Mb chunks, with redundancy 2, the size of "file description", assuming text encoding, will be ~34kb (`128 * (8 + 32 + 64) * 2 * 4/3 + 128 * 4 + (64 + 32 + 32) * 4/3 + 256`). +For 1gb file, sent via 4 different servers, in 8Mb chunks, with redundancy 2, the size of "file description", assuming text encoding, will be ~45kb (`128 * (8 + 32 + 64) * 2 * 4/3 + 128 * 64 * 4/3 + 128 * 4 + (64 + 32 + 32) * 4/3 + 256`). File description format (yml): @@ -132,11 +136,12 @@ chunk: 8Mb hash: abc= key: abc= iv: abc= +part_hashes: [def=, def=, def=, def=] parts: - server: xftp://abc=@example1.com - chunks: [1:abc=:def=, 3:abc=:def=] + chunks: [1:abc=:def=:ghi=, 3:abc=:def=:ghi=] - server: xftp://abc=@example2.com - chunks: [2:abc=:def=, 4:abc=:def=] + chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=] - server: xftp://abc=@example3.com chunks: [1:abc=:def=, 4:abc=:def=] - server: xftp://abc=@example4.com From c4f377a85b016bf89b857c33de367d75447e6712 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 18 Jan 2023 11:07:25 +0000 Subject: [PATCH 08/19] fix SMP server stats (#612) * fix SMP server stats * add server stats test * fix test --- src/Simplex/Messaging/Server/Stats.hs | 4 ++- tests/ServerTests.hs | 35 +++++++++++++++++++++++++-- 2 files changed, 36 insertions(+), 3 deletions(-) diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index 82170e90f..b462eaffa 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -47,6 +47,7 @@ data ServerStatsData = ServerStatsData _qCount :: Int, _msgCount :: Int } + deriving (Show) newServerStats :: UTCTime -> STM ServerStats newServerStats ts = do @@ -88,7 +89,7 @@ setServerStats s d = do writeTVar (qDeleted s) $! _qDeleted d writeTVar (msgSent s) $! _msgSent d writeTVar (msgRecv s) $! _msgRecv d - setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d) + setPeriodStats (activeQueues s) (_activeQueues d) writeTVar (msgSentNtf s) $! _msgSentNtf d writeTVar (msgRecvNtf s) $! _msgRecvNtf d setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d) @@ -152,6 +153,7 @@ data PeriodStatsData a = PeriodStatsData _week :: Set a, _month :: Set a } + deriving (Show) newPeriodStatsData :: PeriodStatsData a newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty} diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 66315336a..5a83e5f1e 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -11,6 +11,7 @@ module ServerTests where +import AgentTests.NotificationTests (removeFileIfExists) import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, try) @@ -20,6 +21,7 @@ import Data.Bifunctor (first) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.Set as S import SMPClient import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -28,6 +30,7 @@ import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) import Simplex.Messaging.Transport import System.Directory (removeFile) import System.TimeIt (timeItT) @@ -605,6 +608,10 @@ logSize f = testRestoreMessages :: ATransport -> Spec testRestoreMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do + removeFileIfExists testStoreLogFile + removeFileIfExists testStoreMsgsFile + removeFileIfExists testServerStatsBackupFile + (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing @@ -632,11 +639,15 @@ testRestoreMessages at@(ATransport t) = Resp "6" _ (ERR QUOTA) <- signSendRecv h sKey ("6", sId, _SEND "hello 6") pure () + rId <- readTVarIO recipientId + logSize testStoreLogFile `shouldReturn` 2 logSize testStoreMsgsFile `shouldReturn` 5 + logSize testServerStatsBackupFile `shouldReturn` 16 + Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile + checkStats stats1 [rId] 5 1 withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do - rId <- readTVarIO recipientId Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -650,9 +661,11 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd logSize testStoreMsgsFile `shouldReturn` 3 + logSize testServerStatsBackupFile `shouldReturn` 16 + Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile + checkStats stats2 [rId] 5 3 withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do - rId <- readTVarIO recipientId Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -667,9 +680,13 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 logSize testStoreMsgsFile `shouldReturn` 0 + logSize testServerStatsBackupFile `shouldReturn` 16 + Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile + checkStats stats3 [rId] 5 5 removeFile testStoreLogFile removeFile testStoreMsgsFile + removeFile testServerStatsBackupFile where runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do @@ -679,6 +696,20 @@ testRestoreMessages at@(ATransport t) = runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () +checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation +checkStats s qs sent received = do + _qCreated s `shouldBe` length qs + _qSecured s `shouldBe` length qs + _qDeleted s `shouldBe` 0 + _msgSent s `shouldBe` sent + _msgRecv s `shouldBe` received + _msgSentNtf s `shouldBe` 0 + _msgRecvNtf s `shouldBe` 0 + let PeriodStatsData {_day, _week, _month} = _activeQueues s + S.toList _day `shouldBe` qs + S.toList _week `shouldBe` qs + S.toList _month `shouldBe` qs + testRestoreMessagesV2 :: ATransport -> Spec testRestoreMessagesV2 at@(ATransport t) = it "should store messages on exit and restore on start" $ do From f921dc3adb0e5d96f1cbd3eff31eb1503e1ae38b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 18 Jan 2023 11:21:45 +0000 Subject: [PATCH 09/19] 4.3.1 --- package.yaml | 2 +- simplexmq.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index d4ed1c127..04d8c773d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 4.3.0 +version: 4.3.1 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, diff --git a/simplexmq.cabal b/simplexmq.cabal index cd0571d83..32fc2decf 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 4.3.0 +version: 4.3.1 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 6ccbe5e66e7d34889ffb11daefc31daf8ac9791c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 18 Jan 2023 14:30:25 +0000 Subject: [PATCH 10/19] retry unsuccessful subscriptions in case of temporary errors (#613) * retry unsuccessful subscriptions in case of temporary errors * do not send DOWN if connection has any active queues --- src/Simplex/Messaging/Agent/Client.hs | 89 ++++++++++++----------- src/Simplex/Messaging/Agent/TRcvQueues.hs | 8 +- 2 files changed, 52 insertions(+), 45 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index a94d866d0..53c9d4304 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -96,7 +96,7 @@ import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Either (isRight, partitionEithers) +import Data.Either (isRight, lefts, partitionEithers) import Data.Functor (($>)) import Data.List (partition) import Data.List.NonEmpty (NonEmpty (..)) @@ -286,7 +286,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped" atomically (getClientVar srv smpClients) >>= either - (newProtocolClient c srv smpClients connectClient reconnectClient) + (newProtocolClient c srv smpClients connectClient reconnectSMPClient) (waitForProtocolClient c srv) where connectClient :: m SMPClient @@ -303,9 +303,11 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do removeClientAndSubs :: IO ([RcvQueue], [ConnId]) removeClientAndSubs = atomically $ do TM.delete srv smpClients - (qs, conns) <- RQ.getDelSrvQueues srv $ activeSubs c + qs <- RQ.getDelSrvQueues srv $ activeSubs c mapM_ (`RQ.addQueue` pendingSubs c) qs - pure (qs, S.toList conns) + let cs = S.fromList $ map (\RcvQueue {connId} -> connId) qs + cs' <- RQ.getConns $ activeSubs c + pure (qs, S.toList $ cs `S.difference` cs') serverDown :: ([RcvQueue], [ConnId]) -> IO () serverDown (qs, conns) = whenM (readTVarIO active) $ do @@ -314,40 +316,41 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do unless (null conns) $ notifySub "" $ DOWN srv conns unless (null qs) $ do atomically $ mapM_ (releaseGetLock c) qs - unliftIO u reconnectServer + unliftIO u $ reconnectServer c srv - reconnectServer :: m () - reconnectServer = do - a <- async tryReconnectClient - atomically $ modifyTVar' (reconnections c) (a :) + notifySub :: ConnId -> ACommand 'Agent -> IO () + notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd) - tryReconnectClient :: m () - tryReconnectClient = do - ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \loop -> - reconnectClient `catchError` const loop - - reconnectClient :: m () - reconnectClient = - withLockMap_ (reconnectLocks c) srv "reconnect" $ - atomically (RQ.getSrvQueues srv $ pendingSubs c) >>= resubscribe - where - resubscribe :: [RcvQueue] -> m () - resubscribe qs = do - connected <- maybe False isRight <$> atomically (TM.lookup srv smpClients $>>= tryReadTMVar) - cs <- atomically . RQ.getConns $ activeSubs c - (client_, rs) <- subscribeQueues c srv qs - let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs - liftIO $ do - unless connected . forM_ client_ $ \cl -> do - incClientStat c cl "CONNECT" "" - notifySub "" $ hostEvent CONNECT cl - let conns = S.toList $ S.fromList okConns `S.difference` cs - unless (null conns) $ notifySub "" $ UP srv conns - let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs - liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs - mapM_ (throwError . snd) $ listToMaybe tempErrs +reconnectServer :: AgentMonad m => AgentClient -> SMPServer -> m () +reconnectServer c srv = do + a <- async tryReconnectSMPClient + atomically $ modifyTVar' (reconnections c) (a :) + where + tryReconnectSMPClient = do + ri <- asks $ reconnectInterval . config + withRetryInterval ri $ \loop -> + reconnectSMPClient c srv `catchError` const loop +reconnectSMPClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m () +reconnectSMPClient c srv = + withLockMap_ (reconnectLocks c) srv "reconnect" $ + atomically (RQ.getSrvQueues srv $ pendingSubs c) >>= resubscribe + where + resubscribe :: [RcvQueue] -> m () + resubscribe qs = do + connected <- maybe False isRight <$> atomically (TM.lookup srv (smpClients c) $>>= tryReadTMVar) + cs <- atomically . RQ.getConns $ activeSubs c + (client_, rs) <- subscribeQueues c srv qs + let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs + liftIO $ do + unless connected . forM_ client_ $ \cl -> do + incClientStat c cl "CONNECT" "" + notifySub "" $ hostEvent CONNECT cl + let conns = S.toList $ S.fromList okConns `S.difference` cs + unless (null conns) $ notifySub "" $ UP srv conns + let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs + liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs + mapM_ (throwError . snd) $ listToMaybe tempErrs notifySub :: ConnId -> ACommand 'Agent -> IO () notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd) @@ -356,7 +359,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped" atomically (getClientVar srv ntfClients) >>= either - (newProtocolClient c srv ntfClients connectClient $ pure ()) + (newProtocolClient c srv ntfClients connectClient $ \_ _ -> pure ()) (waitForProtocolClient c srv) where connectClient :: m NtfClient @@ -396,7 +399,7 @@ newProtocolClient :: ProtoServer msg -> TMap (ProtoServer msg) (ClientVar msg) -> m (ProtocolClient msg) -> - m () -> + (AgentClient -> ProtoServer msg -> m ()) -> ClientVar msg -> m (ProtocolClient msg) newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync @@ -425,7 +428,7 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon connectAsync :: m () connectAsync = do ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop + withRetryInterval ri $ \loop -> void $ tryConnectClient (const $ reconnectClient c srv) loop hostEvent :: forall msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client @@ -609,9 +612,11 @@ subscribeQueue c rq@RcvQueue {connId, server, rcvPrivateKey, rcvId} = do atomically $ do modifyTVar' (subscrConns c) $ S.insert connId RQ.addQueue rq $ pendingSubs c - withLogClient c server rcvId "SUB" $ \smp -> + r <- withLogClient c server rcvId "SUB" $ \smp -> liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq) - >>= either throwError pure + case r of + Left e -> reconnectServer c server >> throwError (protocolClientError SMP (B.unpack $ strEncode server) e) + _ -> pure () processSubResult :: AgentClient -> RcvQueue -> Either ProtocolClientError () -> IO (Either ProtocolClientError ()) processSubResult c rq r = do @@ -646,7 +651,7 @@ subscribeQueues c srv qs = do forM_ qs_ $ \rq@RcvQueue {connId} -> atomically $ do modifyTVar' (subscrConns c) $ S.insert connId RQ.addQueue rq $ pendingSubs c - case L.nonEmpty qs_ of + r <- case L.nonEmpty qs_ of Just qs' -> do smp_ <- tryError (getSMPServerClient c srv) (eitherToMaybe smp_,) . (errs <>) <$> case smp_ of @@ -661,6 +666,8 @@ subscribeQueues c srv qs = do mapM_ (uncurry $ processSubResult c) rs pure $ map (second . first $ protocolClientError SMP $ clientServer smp) rs _ -> pure (Nothing, errs) + when (any temporaryOrHostError . lefts . map snd $ snd r) $ reconnectServer c srv + pure r where checkQueue rq@RcvQueue {rcvId, server} | server == srv = do diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index 9ace32db7..bed4138a2 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs @@ -40,9 +40,9 @@ getSrvQueues srv (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs where addQ qs' rq@RcvQueue {server} = if srv == server then rq : qs' else qs' -getDelSrvQueues :: SMPServer -> TRcvQueues -> STM ([RcvQueue], Set ConnId) -getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ (([], S.empty), M.empty) +getDelSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue] +getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ ([], M.empty) where - addQ (removed@(remQs, remConns), qs') rq@RcvQueue {connId, server, rcvId} - | srv == server = ((rq : remQs, S.insert connId remConns), qs') + addQ (removed, qs') rq@RcvQueue {server, rcvId} + | srv == server = (rq : removed, qs') | otherwise = (removed, M.insert (server, rcvId) rq qs') From 14cb88e725645f4f32cea09e3efdb69e3cbee11f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 18 Jan 2023 18:22:17 +0000 Subject: [PATCH 11/19] remove completed async action handles from memory (#614) * remove completed async action handles from memory * name Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent/Client.hs | 30 ++++++++++++-------------- src/Simplex/Messaging/Agent/TAsyncs.hs | 25 +++++++++++++++++++++ 3 files changed, 40 insertions(+), 16 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/TAsyncs.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 32fc2decf..f49371b96 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -55,6 +55,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues + Simplex.Messaging.Agent.TAsyncs Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 53c9d4304..e4ddda84f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -117,6 +117,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction) +import Simplex.Messaging.Agent.TAsyncs import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues) import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import Simplex.Messaging.Client @@ -156,7 +157,6 @@ import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Timeout (timeout) -import UnliftIO (async) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -196,8 +196,8 @@ data AgentClient = AgentClient connLocks :: TMap ConnId Lock, -- locks to prevent concurrent reconnections to SMP servers reconnectLocks :: TMap SMPServer Lock, - reconnections :: TVar [Async ()], - asyncClients :: TVar [Async ()], + reconnections :: TAsyncs, + asyncClients :: TAsyncs, agentStats :: TMap AgentStatsKey (TVar Int), clientId :: Int, agentEnv :: Env @@ -260,8 +260,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do getMsgLocks <- TM.empty connLocks <- TM.empty reconnectLocks <- TM.empty - reconnections <- newTVar [] - asyncClients <- newTVar [] + reconnections <- newTAsyncs + asyncClients <- newTAsyncs agentStats <- TM.empty clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i') return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useNetworkConfig, subscrConns, activeSubs, pendingSubs, pendingMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, connCmdsQueued, asyncCmdQueues, asyncCmdProcesses, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, connLocks, reconnectLocks, reconnections, asyncClients, agentStats, clientId, agentEnv} @@ -322,14 +322,13 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd) reconnectServer :: AgentMonad m => AgentClient -> SMPServer -> m () -reconnectServer c srv = do - a <- async tryReconnectSMPClient - atomically $ modifyTVar' (reconnections c) (a :) +reconnectServer c srv = newAsyncAction tryReconnectSMPClient $ reconnections c where - tryReconnectSMPClient = do + tryReconnectSMPClient aId = do ri <- asks $ reconnectInterval . config withRetryInterval ri $ \loop -> reconnectSMPClient c srv `catchError` const loop + atomically . removeAsyncAction aId $ reconnections c reconnectSMPClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m () reconnectSMPClient c srv = @@ -422,13 +421,12 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon TM.delete srv clients throwError e tryConnectAsync :: m () - tryConnectAsync = do - a <- async connectAsync - atomically $ modifyTVar' (asyncClients c) (a :) - connectAsync :: m () - connectAsync = do + tryConnectAsync = newAsyncAction connectAsync $ asyncClients c + connectAsync :: Int -> m () + connectAsync aId = do ri <- asks $ reconnectInterval . config withRetryInterval ri $ \loop -> void $ tryConnectClient (const $ reconnectClient c srv) loop + atomically . removeAsyncAction aId $ asyncClients c hostEvent :: forall msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client @@ -444,8 +442,8 @@ closeAgentClient c = liftIO $ do atomically $ writeTVar (active c) False closeProtocolServerClients c smpClients closeProtocolServerClients c ntfClients - cancelActions $ reconnections c - cancelActions $ asyncClients c + cancelActions . actions $ reconnections c + cancelActions . actions $ asyncClients c cancelActions $ smpQueueMsgDeliveries c cancelActions $ asyncCmdProcesses c atomically . RQ.clear $ activeSubs c diff --git a/src/Simplex/Messaging/Agent/TAsyncs.hs b/src/Simplex/Messaging/Agent/TAsyncs.hs new file mode 100644 index 000000000..80fc41840 --- /dev/null +++ b/src/Simplex/Messaging/Agent/TAsyncs.hs @@ -0,0 +1,25 @@ +module Simplex.Messaging.Agent.TAsyncs where + +import Control.Concurrent.STM (stateTVar) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM +import UnliftIO.Async (Async, async) +import UnliftIO.STM + +data TAsyncs = TAsyncs + { actionId :: TVar Int, + actions :: TMap Int (Async ()) + } + +newTAsyncs :: STM TAsyncs +newTAsyncs = TAsyncs <$> newTVar 0 <*> TM.empty + +newAsyncAction :: MonadUnliftIO m => (Int -> m ()) -> TAsyncs -> m () +newAsyncAction action as = do + aId <- atomically $ stateTVar (actionId as) $ \i -> (i + 1, i + 1) + a <- async $ action aId + atomically $ TM.insert aId a $ actions as + +removeAsyncAction :: Int -> TAsyncs -> STM () +removeAsyncAction aId = TM.delete aId . actions From 4f4b4f7eeec151f7535bcdae6c269d4f6f65900c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 18 Jan 2023 22:03:43 +0000 Subject: [PATCH 12/19] only reconnect client on temporary errors in single subscription too (not currently used) (#616) * only reconnect client on temporary errors in single subscription too (not currently used) * refactor --- src/Simplex/Messaging/Agent/Client.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index e4ddda84f..205d13957 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -611,9 +611,11 @@ subscribeQueue c rq@RcvQueue {connId, server, rcvPrivateKey, rcvId} = do modifyTVar' (subscrConns c) $ S.insert connId RQ.addQueue rq $ pendingSubs c r <- withLogClient c server rcvId "SUB" $ \smp -> - liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq) + liftIO $ runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq case r of - Left e -> reconnectServer c server >> throwError (protocolClientError SMP (B.unpack $ strEncode server) e) + Left e -> do + when (temporaryClientError e) $ reconnectServer c server + throwError (protocolClientError SMP (B.unpack $ strEncode server) e) _ -> pure () processSubResult :: AgentClient -> RcvQueue -> Either ProtocolClientError () -> IO (Either ProtocolClientError ()) From a854b5f2b210024485ee615fe9695b54ce369358 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 19 Jan 2023 16:53:28 +0000 Subject: [PATCH 13/19] batched queue deletion (#611) * batched queue deletion * only re-connect client on subscribe errors, not in all batch commands * add test, fix * correction Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> * refactor Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- src/Simplex/Messaging/Agent.hs | 66 +++++++++++++++++-- src/Simplex/Messaging/Agent/Client.hs | 72 +++++++++++++++------ src/Simplex/Messaging/Agent/Store/SQLite.hs | 4 +- src/Simplex/Messaging/Client.hs | 29 ++++++--- tests/AgentTests/FunctionalAPITests.hs | 34 ++++++++-- 5 files changed, 160 insertions(+), 45 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index f5747e51c..d62426e7f 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -63,6 +63,7 @@ module Simplex.Messaging.Agent switchConnection, suspendConnection, deleteConnection, + deleteConnections, getConnectionServers, getConnectionRatchetAdHash, setSMPServers, @@ -255,6 +256,10 @@ suspendConnection c = withAgentEnv c . suspendConnection' c deleteConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m () deleteConnection c = withAgentEnv c . deleteConnection' c +-- | Delete multiple connections, batching commands when possible +deleteConnections :: AgentErrorMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) +deleteConnections c = withAgentEnv c . deleteConnections' c + -- | get servers used for connection getConnectionServers :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats getConnectionServers c = withAgentEnv c . getConnectionServers' c @@ -624,7 +629,7 @@ subscribeConnection' c connId = do ns <- asks ntfSupervisor atomically $ sendNtfSubCommand ns (connId, if enableNtfs then NSCCreate else NSCDelete) -type QSubResult = (QueueStatus, Either AgentErrorType ()) +type QCmdResult = (QueueStatus, Either AgentErrorType ()) subscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) subscribeConnections' _ [] = pure M.empty @@ -659,13 +664,13 @@ subscribeConnections' c connIds = do connResults = M.map snd . foldl' addResult M.empty where -- collects results by connection ID - addResult :: Map ConnId QSubResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QSubResult + addResult :: Map ConnId QCmdResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QCmdResult addResult rs (RcvQueue {connId, status}, r) = M.alter (combineRes (status, r)) connId rs -- combines two results for one connection, by using only Active queues (if there is at least one Active queue) - combineRes :: QSubResult -> Maybe QSubResult -> Maybe QSubResult + combineRes :: QCmdResult -> Maybe QCmdResult -> Maybe QCmdResult combineRes r' (Just r) = Just $ if order r <= order r' then r else r' combineRes r' _ = Just r' - order :: QSubResult -> Int + order :: QCmdResult -> Int order (Active, Right _) = 1 order (Active, _) = 2 order (_, Right _) = 3 @@ -877,7 +882,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do | primary -> internalErr "ICQDelete: cannot delete primary rcv queue" | otherwise -> do deleteQueue c rq' - withStore' c $ \db -> deleteConnRcvQueue db connId rq' + withStore' c $ \db -> deleteConnRcvQueue db rq' when (enableNtfs cData) $ do ns <- asks ntfSupervisor atomically $ sendNtfSubCommand ns (connId, NSCCreate) @@ -1206,9 +1211,10 @@ deleteConnection' c connId = withConnLock c connId "deleteConnection" $ do deleteConn' = withStore' c (`deleteConn` connId) deleteConnQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () -deleteConnQueue c rq@RcvQueue {connId} = do +deleteConnQueue c rq = do deleteQueue c rq - withStore' c $ \db -> deleteConnRcvQueue db connId rq + withStore' c $ \db -> deleteConnRcvQueue db rq + removeQueueSubscription c rq disableConn :: AgentMonad m => AgentClient -> ConnId -> m () disableConn c connId = do @@ -1216,6 +1222,52 @@ disableConn c connId = do ns <- asks ntfSupervisor atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete) +deleteConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) +deleteConnections' _ [] = pure M.empty +deleteConnections' c connIds = do + conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConn) + let (errs, cs) = M.mapEither id conns + errs' = M.map (Left . storeError) errs + (delRs, rcvQs) = M.mapEither rcvQueueOrResult cs + rcvRs <- deleteQueues c (concat $ M.elems rcvQs) + forM_ rcvRs $ \case + (rq, Right _) -> withStore' c (`deleteConnRcvQueue` rq) >> removeQueueSubscription c rq + _ -> pure () + let rs = M.unions ([errs', delRs, connResults rcvRs] :: [Map ConnId (Either AgentErrorType ())]) + forM_ (M.assocs rs) $ \case + (connId, Right _) -> disableConn c connId >> withStore' c (`deleteConn` connId) + _ -> pure () + notifyResultError rs + pure rs + where + rcvQueueOrResult :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue] + rcvQueueOrResult (SomeConn _ conn) = case conn of + DuplexConnection _ rqs _ -> Right $ L.toList rqs + RcvConnection _ rq -> Right [rq] + ContactConnection _ rq -> Right [rq] + SndConnection _ _ -> Left $ Right () + NewConnection _ -> Left $ Right () + connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) + connResults = M.map snd . foldl' addResult M.empty + where + -- collects results by connection ID + addResult :: Map ConnId QCmdResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QCmdResult + addResult rs (RcvQueue {connId, status}, r) = M.alter (combineRes (status, r)) connId rs + -- combines two results for one connection, by prioritizing errors in Active queues + combineRes :: QCmdResult -> Maybe QCmdResult -> Maybe QCmdResult + combineRes r' (Just r) = Just $ if order r <= order r' then r else r' + combineRes r' _ = Just r' + order :: QCmdResult -> Int + order (Active, Left _) = 1 + order (_, Left _) = 2 + order _ = 3 + notifyResultError :: Map ConnId (Either AgentErrorType ()) -> m () + notifyResultError rs = do + let actual = M.size rs + expected = length connIds + when (actual /= expected) . atomically $ + writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) + getConnectionServers' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats getConnectionServers' c connId = do SomeConn _ conn <- withStore c (`getConn` connId) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 7a1628dc2..045ce62df 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -54,8 +54,10 @@ module Simplex.Messaging.Agent.Client sendAck, suspendQueue, deleteQueue, + deleteQueues, logServer, logSecret, + removeQueueSubscription, removeSubscription, hasActiveSubscription, agentClientStore, @@ -690,31 +692,51 @@ subscribeQueues c qs = do forM_ qs' $ \rq@RcvQueue {connId} -> atomically $ do modifyTVar (subscrConns c) $ S.insert connId RQ.addQueue rq $ pendingSubs c - (errs <>) <$> do - mode <- sessionMode <$> readTVarIO (useNetworkConfig c) - let sessRcvQs = foldl' (addRcvQueue mode) M.empty qs' - concat <$> mapConcurrently (fmap L.toList . uncurry (subscribeQueues_ c)) (M.assocs sessRcvQs) + u <- askUnliftIO + (errs <>) <$> sendTSessionBatches "SUB" 90 (subscribeQueues_ u) c qs where checkQueue rq@RcvQueue {rcvId, server} = do prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq - addRcvQueue :: TransportSessionMode -> Map SMPTransportSession (NonEmpty RcvQueue) -> RcvQueue -> Map SMPTransportSession (NonEmpty RcvQueue) - addRcvQueue mode m rq = - let tSess = mkSMPTSession rq mode - in M.alter (Just . maybe [rq] (rq <|)) tSess m + subscribeQueues_ u smp qs' = do + rs <- sendBatch subscribeSMPQueues smp qs' + mapM_ (uncurry $ processSubResult c) rs + when (any temporaryClientError . lefts . map snd $ L.toList rs) $ + unliftIO u $ reconnectServer c $ transportSession' smp + pure rs -subscribeQueues_ :: AgentMonad m => AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> m (NonEmpty (RcvQueue, Either AgentErrorType ())) -subscribeQueues_ c tSess@(userId, srv, _) qs = do - tryError (getSMPServerClient c tSess) >>= \case - Left e -> pure $ L.map (,Left e) qs - Right smp -> do - logServer "-->" c srv (bshow (length qs) <> " queues") "SUB" - let n = (length qs - 1) `div` 90 + 1 - liftIO $ incClientStatN c userId smp n "SUBS" "OK" - rs <- liftIO $ L.zip qs <$> subscribeSMPQueues smp (L.map queueCreds qs) - liftIO $ mapM_ (uncurry $ processSubResult c) rs - when (any temporaryClientError . lefts . map snd $ L.toList rs) $ reconnectServer c tSess - pure $ L.map (second . first $ protocolClientError SMP $ clientServer smp) rs +type BatchResponses e = (NonEmpty (RcvQueue, Either e ())) + +-- statBatchSize is not used to batch the commands, only for traffic statistics +sendTSessionBatches :: forall m. AgentMonad m => ByteString -> Int -> (SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses ProtocolClientError)) -> AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())] +sendTSessionBatches statCmd statBatchSize action c qs = + concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues) + where + batchQueues :: m [(SMPTransportSession, NonEmpty RcvQueue)] + batchQueues = do + mode <- sessionMode <$> readTVarIO (useNetworkConfig c) + pure . M.assocs $ foldl' (batch mode) M.empty qs + where + batch mode m rq = + let tSess = mkSMPTSession rq mode + in M.alter (Just . maybe [rq] (rq <|)) tSess m + sendClientBatch :: (SMPTransportSession, NonEmpty RcvQueue) -> m (BatchResponses AgentErrorType) + sendClientBatch (tSess@(userId, srv, _), qs') = + tryError (getSMPServerClient c tSess) >>= \case + Left e -> pure $ L.map (,Left e) qs' + Right smp -> liftIO $ do + logServer "-->" c srv (bshow (length qs') <> " queues") statCmd + rs <- L.map agentError <$> action smp qs' + statBatch + pure rs + where + agentError = second . first $ protocolClientError SMP $ clientServer smp + statBatch = + let n = (length qs - 1) `div` statBatchSize + 1 + in incClientStatN c userId smp n (statCmd <> "S") "OK" + +sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses ProtocolClientError) +sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs) where queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId) @@ -724,6 +746,11 @@ addSubscription c rq@RcvQueue {connId} = atomically $ do RQ.addQueue rq $ activeSubs c RQ.deleteQueue rq $ pendingSubs c +removeQueueSubscription :: MonadIO m => AgentClient -> RcvQueue -> m () +removeQueueSubscription c rq = atomically $ do + RQ.deleteQueue rq $ activeSubs c + RQ.deleteQueue rq $ pendingSubs c + hasActiveSubscription :: AgentClient -> ConnId -> STM Bool hasActiveSubscription c connId = RQ.hasConn connId $ activeSubs c @@ -822,10 +849,13 @@ suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = suspendSMPQueue smp rcvPrivateKey rcvId deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () -deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = +deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do withSMPClient c rq "DEL" $ \smp -> deleteSMPQueue smp rcvPrivateKey rcvId +deleteQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())] +deleteQueues = sendTSessionBatches "DEL" 90 $ sendBatch deleteSMPQueues + sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m () sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg = withSMPClient_ c sq "SEND " $ \smp -> do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 59e6b41e2..ff9eb6329 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -471,8 +471,8 @@ setSndQueuePrimary db connId SndQueue {dbQueueId} = do "UPDATE snd_queues SET snd_primary = ?, replace_snd_queue_id = ? WHERE conn_id = ? AND snd_queue_id = ?" (True, Nothing :: Maybe Int64, connId, dbQueueId) -deleteConnRcvQueue :: DB.Connection -> ConnId -> RcvQueue -> IO () -deleteConnRcvQueue db connId RcvQueue {dbQueueId} = +deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO () +deleteConnRcvQueue db RcvQueue {connId, dbQueueId} = DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) deleteConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO () diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 5f67bcc95..0b64fabf6 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -33,6 +33,7 @@ module Simplex.Messaging.Client closeProtocolClient, clientServer, transportHost', + transportSession', -- * SMP protocol command functions createSMPQueue, @@ -49,6 +50,7 @@ module Simplex.Messaging.Client ackSMPMessage, suspendSMPQueue, deleteSMPQueue, + deleteSMPQueues, sendProtocolCommand, -- * Supporting types and client configuration @@ -252,6 +254,9 @@ clientServer = B.unpack . strEncode . snd3 . transportSession . client_ transportHost' :: ProtocolClient msg -> TransportHost transportHost' = transportHost . client_ +transportSession' :: ProtocolClient msg -> TransportSession msg +transportSession' = transportSession . client_ + type UserId = Int64 -- | Transport session key - includes entity ID if `sessionMode = TSMEntity`. @@ -491,13 +496,7 @@ disableSMPQueueNotifications = okSMPCommand NDEL -- | Disable notifications for multiple queues for push notifications server. disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ())) -disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs - where - cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs - response = \case - Right OK -> Right () - Right r -> Left . PCEUnexpectedResponse $ bshow r - Left e -> Left e +disableSMPQueuesNtfs = okSMPCommands NDEL -- | Send SMP message. -- @@ -528,15 +527,29 @@ suspendSMPQueue = okSMPCommand OFF -- | Irreversibly delete SMP queue and all messages in it. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue -deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO () +deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO () deleteSMPQueue = okSMPCommand DEL +-- | Delete multiple SMP queues batching commands if supported. +deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ())) +deleteSMPQueues = okSMPCommands DEL + okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case OK -> return () r -> throwE . PCEUnexpectedResponse $ bshow r +okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either ProtocolClientError ())) +okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs + where + aCmd = Cmd sParty cmd + cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs + response = \case + Right OK -> Right () + Right r -> Left . PCEUnexpectedResponse $ bshow r + Left e -> Left e + -- | Send SMP command sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 989d65230..07285fd63 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -30,6 +30,7 @@ import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.IO.Unlift import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Either (isRight) import Data.Int (Int64) import qualified Data.Map as M import Data.Maybe (isNothing) @@ -577,9 +578,9 @@ testBatchedSubscriptions t = do conns <- runServers $ do conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId - forM_ (take 10 conns) $ \(aId, bId) -> do - deleteConnection a bId - deleteConnection b aId + let (aIds', bIds') = unzip $ take 10 conns + delete a bIds' + delete b aIds' liftIO $ threadDelay 1000000 pure conns ("", "", DOWN {}) <- get a @@ -592,18 +593,37 @@ testBatchedSubscriptions t = do ("", "", UP {}) <- get b ("", "", UP {}) <- get b liftIO $ threadDelay 1000000 - subscribe a $ map snd conns - subscribe b $ map fst conns - forM_ (drop 10 conns) $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId + let (aIds, bIds) = unzip conns + conns' = drop 10 conns + (aIds', bIds') = unzip conns' + subscribe a bIds + subscribe b aIds + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId + delete a bIds' + delete b aIds' + deleteFail a bIds' + deleteFail b aIds' where subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO () subscribe c cs = do r <- subscribeConnections c cs liftIO $ do let dc = S.fromList $ take 10 cs - all (== Right ()) (M.withoutKeys r dc) `shouldBe` True + all isRight (M.withoutKeys r dc) `shouldBe` True all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True M.keys r `shouldMatchList` cs + delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO () + delete c cs = do + r <- deleteConnections c cs + liftIO $ do + all isRight r `shouldBe` True + M.keys r `shouldMatchList` cs + deleteFail :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO () + deleteFail c cs = do + r <- deleteConnections c cs + liftIO $ do + all (== Left (CONN NOT_FOUND)) r `shouldBe` True + M.keys r `shouldMatchList` cs runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn t testPort $ \t1 -> do From 56eea29ec36ba723fda6ae27a18e03a4e5aad6e8 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 19 Jan 2023 17:45:06 +0000 Subject: [PATCH 14/19] end SMP client connection after configured number of PING errors, reset PING error count on any success (#615) * end SMP client connection after configured number of PING errors, reset PING error count on any success * only terminate client on PING timeout * refactor * comment --- src/Simplex/Messaging/Client.hs | 36 +++++++++++++------ src/Simplex/Messaging/Notifications/Server.hs | 2 ++ .../Messaging/Notifications/Server/Env.hs | 1 + tests/SMPAgentClient.hs | 13 ++----- 4 files changed, 30 insertions(+), 22 deletions(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 611702b69..2178400b0 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -113,6 +113,7 @@ data PClient msg = PClient protocolServer :: ProtoServer msg, transportHost :: TransportHost, tcpTimeout :: Int, + pingErrorCount :: TVar Int, clientCorrId :: TVar Natural, sentCommands :: TMap CorrId (Request msg), sndQ :: TBQueue (NonEmpty SentRawTransmission), @@ -158,8 +159,10 @@ data NetworkConfig = NetworkConfig tcpTimeout :: Int, -- | TCP keep-alive options, Nothing to skip enabling keep-alive tcpKeepAlive :: Maybe KeepAliveOpts, - -- | period for SMP ping commands (microseconds) + -- | period for SMP ping commands (microseconds, 0 to disable) smpPingInterval :: Int, + -- | the count of PING errors after which SMP client terminates (and will be reconnected), 0 to disable + smpPingCount :: Int, logTLSErrors :: Bool } deriving (Eq, Show, Generic, FromJSON) @@ -178,6 +181,7 @@ defaultNetworkConfig = tcpTimeout = 5_000_000, tcpKeepAlive = Just defaultKeepAliveOpts, smpPingInterval = 600_000_000, -- 10min + smpPingCount = 3, logTLSErrors = False } @@ -251,6 +255,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, mkProtocolClient :: TransportHost -> STM (PClient msg) mkProtocolClient transportHost = do connected <- newTVar False + pingErrorCount <- newTVar 0 clientCorrId <- newTVar 0 sentCommands <- TM.empty sndQ <- newTBQueue qSize @@ -261,6 +266,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, protocolServer, transportHost, tcpTimeout, + pingErrorCount, clientCorrId, sentCommands, sndQ, @@ -308,9 +314,15 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ ping :: ProtocolClient msg -> IO () - ping c = forever $ do + ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do threadDelay smpPingInterval - runExceptT $ sendProtocolCommand c Nothing "" protocolPing + runExceptT (sendProtocolCommand c Nothing "" protocolPing) >>= \case + Left PCEResponseTimeout -> do + cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1) + when (maxCnt == 0 || cnt < maxCnt) $ ping c + _ -> ping c -- sendProtocolCommand resets pingErrorCount + where + maxCnt = smpPingCount networkConfig process :: ProtocolClient msg -> IO () process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c) @@ -516,26 +528,28 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd) -- | Send multiple commands with batching and collect responses sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg)) -sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} cs = do +sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ}} cs = do ts <- mapM (runExceptT . mkTransmission c) cs mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts forConcurrently ts $ \case - Right (_, r) -> withTimeout . atomically $ takeTMVar r + Right (_, r) -> withTimeout c $ atomically $ takeTMVar r Left e -> pure $ Left e - where - withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a -- | Send Protocol command sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg -sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} pKey qId cmd = do +sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}} pKey qId cmd = do (t, r) <- mkTransmission c (pKey, qId, cmd) ExceptT $ sendRecv t r where -- two separate "atomically" needed to avoid blocking sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg) - sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r) - where - withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a + sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c (atomically $ takeTMVar r) + +withTimeout :: ProtocolClient msg -> IO (Either ProtocolClientError msg) -> IO (Either ProtocolClientError msg) +withTimeout ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} a = + timeout tcpTimeout a >>= \case + Just r -> atomically (writeTVar pingErrorCount 0) >> pure r + _ -> pure $ Left PCEResponseTimeout mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg)) mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 80069a534..3252cd0c6 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -372,6 +372,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId NtfCmd SSubscription c -> do s_ <- atomically $ getNtfSubscription st entId case s_ of @@ -529,6 +530,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu incNtfStat subDeleted pure NROk PING -> pure NRPong + NtfReqPing corrId entId -> pure (corrId, entId, NRPong) getId :: M NtfEntityId getId = getRandomBytes =<< asks (subIdBytes . config) getRegCode :: M NtfRegCode diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 068af65c9..f3002e1bc 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -148,6 +148,7 @@ getPushClient s@NtfPushServer {pushClients} pp = data NtfRequest = NtfReqNew CorrId ANewNtfEntity | forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e)) + | NtfReqPing CorrId NtfEntityId data NtfServerClient = NtfServerClient { rcvQ :: TBQueue NtfRequest, diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 16efc39f0..6f7ec2274 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -187,17 +187,8 @@ agentCfg = { tcpPort = agentTestPort, tbqSize = 4, database = testDB, - smpCfg = - defaultClientConfig - { qSize = 1, - defaultTransport = (testPort, transport @TLS), - networkConfig = defaultNetworkConfig {tcpTimeout = 500_000} - }, - ntfCfg = - defaultClientConfig - { qSize = 1, - defaultTransport = (ntfTestPort, transport @TLS) - }, + smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS)}, + ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS)}, reconnectInterval = defaultReconnectInterval {initialInterval = 50_000}, ntfWorkerDelay = 1000, ntfSMPWorkerDelay = 1000, From d4fc638478a9dee69234ea0aaf212fee5cd0e323 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 21 Jan 2023 13:41:16 +0000 Subject: [PATCH 15/19] async batch connection deletion (#617) * async batch connection deletion * delete user record with connections, async connection deletion * updates * update query --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 199 +++++++++++++----- src/Simplex/Messaging/Agent/Client.hs | 54 ++++- src/Simplex/Messaging/Agent/Env/SQLite.hs | 6 + src/Simplex/Messaging/Agent/Lock.hs | 4 + src/Simplex/Messaging/Agent/Store.hs | 3 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 71 ++++++- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../Migrations/M20230120_delete_errors.hs | 20 ++ .../Store/SQLite/Migrations/agent_schema.sql | 7 +- tests/AgentTests/FunctionalAPITests.hs | 13 +- tests/AgentTests/SQLiteTests.hs | 6 +- 12 files changed, 299 insertions(+), 89 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230120_delete_errors.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index f9998b7ac..8fc52c556 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -57,6 +57,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors Simplex.Messaging.Agent.TAsyncs Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d62426e7f..4f52bc3a4 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -47,6 +47,7 @@ module Simplex.Messaging.Agent ackMessageAsync, switchConnectionAsync, deleteConnectionAsync, + deleteConnectionsAsync, createConnection, joinConnection, allowConnection, @@ -113,6 +114,7 @@ import Data.Time.Clock.System (systemToUTCTime) import qualified Database.SQLite.Simple as DB import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite +import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.NtfSubSupervisor import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval @@ -146,7 +148,7 @@ getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent where runAgent = do c <- getAgentClient initServers - void $ race_ (subscriber c) (runNtfSupervisor c) `forkFinally` const (disconnectAgentClient c) + void $ raceAny_ [subscriber c, runNtfSupervisor c, cleanupManager c] `forkFinally` const (disconnectAgentClient c) pure c disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m () @@ -158,14 +160,14 @@ disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns}} = do resumeAgentClient :: MonadIO m => AgentClient -> m () resumeAgentClient c = atomically $ writeTVar (active c) True --- | type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m) createUser :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId createUser c = withAgentEnv c . createUser' c -deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> m () -deleteUser c = withAgentEnv c . deleteUser' c +-- | Delete user record optionally deleting all user's connections on SMP servers +deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> m () +deleteUser c = withAgentEnv c .: deleteUser' c -- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId @@ -192,8 +194,12 @@ switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId - switchConnectionAsync c = withAgentEnv c .: switchConnectionAsync' c -- | Delete SMP agent connection (DEL command) asynchronously, no synchronous response -deleteConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> m () -deleteConnectionAsync c = withAgentEnv c .: deleteConnectionAsync' c +deleteConnectionAsync :: AgentErrorMonad m => AgentClient -> ConnId -> m () +deleteConnectionAsync c = withAgentEnv c . deleteConnectionAsync' c + +-- -- | Delete SMP agent connections using batch commands asynchronously, no synchronous response +deleteConnectionsAsync :: AgentErrorMonad m => AgentClient -> [ConnId] -> m () +deleteConnectionsAsync c = withAgentEnv c . deleteConnectionsAsync' c -- | Create SMP agent connection (NEW command) createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) @@ -384,9 +390,11 @@ createUser' c srvs = do atomically $ TM.insert userId srvs $ smpServers c pure userId -deleteUser' :: AgentMonad m => AgentClient -> UserId -> m () -deleteUser' c userId = do - withStore c (`deleteUserRecord` userId) +deleteUser' :: AgentMonad m => AgentClient -> UserId -> Bool -> m () +deleteUser' c userId delSMPQueues = do + if delSMPQueues + then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ (Just userId) c + else withStore c (`deleteUserRecord` userId) atomically $ TM.delete userId $ smpServers c newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId @@ -450,23 +458,36 @@ ackMessageAsync' c corrId connId msgId = do (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId -deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ACorrId -> ConnId -> m () -deleteConnectionAsync' c@AgentClient {subQ} corrId connId = withConnLock c connId "deleteConnectionAsync" $ do +deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () +deleteConnectionAsync' c connId = withConnLock c connId "deleteConnectionAsync" $ do SomeConn _ conn <- withStore c (`getConn` connId) - case conn of - DuplexConnection _ (rq :| _) _ -> enqueueDelete rq - RcvConnection _ rq -> enqueueDelete rq - ContactConnection _ rq -> enqueueDelete rq - SndConnection _ _ -> delete - NewConnection _ -> delete - where - enqueueDelete :: RcvQueue -> m () - enqueueDelete RcvQueue {server} = do - withStore' c $ \db -> setConnDeleted db connId + case connRcvQueues conn of + [] -> delete + rqs -> do + withStore' c (`setConnDeleted` connId) disableConn c connId - enqueueCommand c corrId connId (Just server) $ AInternalCommand ICDeleteConn - delete :: m () - delete = withStore' c (`deleteConn` connId) >> atomically (writeTBQueue subQ (corrId, connId, OK)) + void . forkIO $ do + forM_ rqs $ deleteConnQueue c + delete + where + delete = withStore' c (`deleteConn` connId) + +deleteConnectionsAsync' :: AgentMonad m => AgentClient -> [ConnId] -> m () +deleteConnectionsAsync' = deleteConnectionsAsync_ Nothing + +deleteConnectionsAsync_ :: forall m. AgentMonad m => Maybe UserId -> AgentClient -> [ConnId] -> m () +deleteConnectionsAsync_ userId_ c connIds = case connIds of + [] -> delUser + _ -> do + (_, rqs, connIds') <- prepareDeleteConnections_ getConn c connIds + withStore' c $ forM_ connIds' . setConnDeleted + void . forkIO $ + withLock (deleteLock c) "deleteConnectionsAsync" $ do + void $ deleteConnQueues c rqs + delUser + where + delUser :: m () + delUser = forM_ userId_ $ \userId -> withStore' c (`deleteUserWithoutConns` userId) -- | Add connection to the new receive queue switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m () @@ -851,7 +872,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO ICDeleteConn -> withServer $ \srv -> tryWithLock "ICDeleteConn" $ do - SomeConn _ conn <- withStore c $ \db -> getAnyConn db connId True + SomeConn _ conn <- withStore c $ \db -> getDeletedConn db connId case conn of DuplexConnection _ (rq :| rqs) _ -> delete srv rq $ case rqs of [] -> notify OK @@ -1196,25 +1217,36 @@ suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do NewConnection _ -> throwError $ CMD PROHIBITED -- | Delete SMP agent connection (DEL command) in Reader monad +-- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure +-- currently it is used only in tests deleteConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () deleteConnection' c connId = withConnLock c connId "deleteConnection" $ do SomeConn _ conn <- withStore c (`getConn` connId) - case conn of - DuplexConnection _ rqs _ -> mapM_ (deleteConnQueue c) rqs >> disableConn c connId >> deleteConn' - RcvConnection _ rq -> delete rq - ContactConnection _ rq -> delete rq - SndConnection _ _ -> deleteConn' - NewConnection _ -> deleteConn' - where - delete :: RcvQueue -> m () - delete rq = deleteConnQueue c rq >> disableConn c connId >> deleteConn' - deleteConn' = withStore' c (`deleteConn` connId) + let rqs = connRcvQueues conn + unless (null rqs) $ do + disableConn c connId + forM_ rqs $ deleteConnQueue c + withStore' c (`deleteConn` connId) + +connRcvQueues :: Connection d -> [RcvQueue] +connRcvQueues = \case + DuplexConnection _ rqs _ -> L.toList rqs + RcvConnection _ rq -> [rq] + ContactConnection _ rq -> [rq] + SndConnection _ _ -> [] + NewConnection _ -> [] deleteConnQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () deleteConnQueue c rq = do - deleteQueue c rq - withStore' c $ \db -> deleteConnRcvQueue db rq - removeQueueSubscription c rq + maxErrs <- asks $ deleteErrorCount . config + deleteQueue c rq `catchError` handleError maxErrs + withStore' c (`deleteConnRcvQueue` rq) + where + handleError maxErrs e + | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs = do + withStore' c (`incRcvDeleteErrors` rq) + throwError e + | otherwise = pure () disableConn :: AgentMonad m => AgentClient -> ConnId -> m () disableConn c connId = do @@ -1222,31 +1254,54 @@ disableConn c connId = do ns <- asks ntfSupervisor atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete) +-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure. deleteConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) -deleteConnections' _ [] = pure M.empty -deleteConnections' c connIds = do - conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConn) +deleteConnections' = deleteConnections_ getConn + +deleteDeletedConns :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) +deleteDeletedConns = deleteConnections_ getDeletedConn + +prepareDeleteConnections_ :: + forall m. + AgentMonad m => + (DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) -> + AgentClient -> + [ConnId] -> + m (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId]) +prepareDeleteConnections_ getConnection c connIds = do + conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConnection) let (errs, cs) = M.mapEither id conns errs' = M.map (Left . storeError) errs - (delRs, rcvQs) = M.mapEither rcvQueueOrResult cs - rcvRs <- deleteQueues c (concat $ M.elems rcvQs) - forM_ rcvRs $ \case - (rq, Right _) -> withStore' c (`deleteConnRcvQueue` rq) >> removeQueueSubscription c rq - _ -> pure () - let rs = M.unions ([errs', delRs, connResults rcvRs] :: [Map ConnId (Either AgentErrorType ())]) + (delRs, rcvQs) = M.mapEither rcvQueues cs + rqs = concat $ M.elems rcvQs + connIds' = M.keys rcvQs + forM_ connIds' $ disableConn c + withStore' c $ forM_ (M.keys delRs) . deleteConn + pure (errs' <> delRs, rqs, connIds') + where + rcvQueues :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue] + rcvQueues (SomeConn _ conn) = case connRcvQueues conn of + [] -> Left $ Right () + rqs -> Right rqs + +deleteConnQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m (Map ConnId (Either AgentErrorType ())) +deleteConnQueues c rqs = do + rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs) forM_ (M.assocs rs) $ \case - (connId, Right _) -> disableConn c connId >> withStore' c (`deleteConn` connId) + (connId, Right _) -> withStore' c (`deleteConn` connId) _ -> pure () - notifyResultError rs pure rs where - rcvQueueOrResult :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue] - rcvQueueOrResult (SomeConn _ conn) = case conn of - DuplexConnection _ rqs _ -> Right $ L.toList rqs - RcvConnection _ rq -> Right [rq] - ContactConnection _ rq -> Right [rq] - SndConnection _ _ -> Left $ Right () - NewConnection _ -> Left $ Right () + deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())] -> m [(RcvQueue, Either AgentErrorType ())] + deleteQueueRecs rs = do + maxErrs <- asks $ deleteErrorCount . config + forM rs $ \(rq, r) -> do + r' <- case r of + Right _ -> withStore' c (`deleteConnRcvQueue` rq) $> r + Left e + | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> withStore' c (`incRcvDeleteErrors` rq) $> r + | otherwise -> withStore' c (`deleteConnRcvQueue` rq) $> Right () + pure (rq, r') connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty where @@ -1261,6 +1316,22 @@ deleteConnections' c connIds = do order (Active, Left _) = 1 order (_, Left _) = 2 order _ = 3 + +deleteConnections_ :: + forall m. + AgentMonad m => + (DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) -> + AgentClient -> + [ConnId] -> + m (Map ConnId (Either AgentErrorType ())) +deleteConnections_ _ _ [] = pure M.empty +deleteConnections_ getConnection c connIds = do + (rs, rqs, _) <- prepareDeleteConnections_ getConnection c connIds + rcvRs <- deleteConnQueues c rqs + let rs' = M.union rs rcvRs + notifyResultError rs' + pure rs' + where notifyResultError :: Map ConnId (Either AgentErrorType ()) -> m () notifyResultError rs = do let actual = M.size rs @@ -1520,10 +1591,11 @@ execAgentStoreSQL' :: AgentMonad m => AgentClient -> Text -> m [Text] execAgentStoreSQL' c sql = withStore' c (`execSQL` sql) debugAgentLocks' :: AgentMonad m => AgentClient -> m AgentLocks -debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs} = do +debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock = d} = do connLocks <- getLocks cs srvLocks <- getLocks rs - pure AgentLocks {connLocks, srvLocks} + delLock <- atomically $ tryReadTMVar d + pure AgentLocks {connLocks, srvLocks, delLock} where getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls) @@ -1557,6 +1629,17 @@ subscriber c@AgentClient {msgQ} = forever $ do Left e -> liftIO $ print e Right _ -> return () +cleanupManager :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +cleanupManager c = do + threadDelay =<< asks (initialCleanupDelay . config) + int <- asks (cleanupInterval . config) + forever $ do + void . runExceptT $ + withLock (deleteLock c) "cleanupManager" $ do + void $ withStore' c getDeletedConns >>= deleteDeletedConns c + withStore' c deleteUsersWithoutConns + threadDelay int + processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m () processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do (rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 045ce62df..3975c8d12 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -57,7 +57,6 @@ module Simplex.Messaging.Agent.Client deleteQueues, logServer, logSecret, - removeQueueSubscription, removeSubscription, hasActiveSubscription, agentClientStore, @@ -202,6 +201,8 @@ data AgentClient = AgentClient getMsgLocks :: TMap (SMPServer, SMP.RecipientId) (TMVar ()), -- locks to prevent concurrent operations with connection connLocks :: TMap ConnId Lock, + -- lock to prevent concurrency between periodic and async connection deletions + deleteLock :: Lock, -- locks to prevent concurrent reconnections to SMP servers reconnectLocks :: TMap SMPTransportSession Lock, reconnections :: TAsyncs, @@ -230,7 +231,7 @@ data AgentOpState = AgentOpState {opSuspended :: Bool, opsInProgress :: Int} data AgentState = ASActive | ASSuspending | ASSuspended deriving (Eq, Show) -data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map String String} +data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map String String, delLock :: Maybe String} deriving (Show, Generic) instance ToJSON AgentLocks where toEncoding = J.genericToEncoding J.defaultOptions @@ -273,12 +274,48 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do agentState <- newTVar ASActive getMsgLocks <- TM.empty connLocks <- TM.empty + deleteLock <- createLock reconnectLocks <- TM.empty reconnections <- newTAsyncs asyncClients <- newTAsyncs agentStats <- TM.empty clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i') - return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useNetworkConfig, subscrConns, activeSubs, pendingSubs, pendingMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, connCmdsQueued, asyncCmdQueues, asyncCmdProcesses, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, connLocks, reconnectLocks, reconnections, asyncClients, agentStats, clientId, agentEnv} + return + AgentClient + { active, + rcvQ, + subQ, + msgQ, + smpServers, + smpClients, + ntfServers, + ntfClients, + useNetworkConfig, + subscrConns, + activeSubs, + pendingSubs, + pendingMsgsQueued, + smpQueueMsgQueues, + smpQueueMsgDeliveries, + connCmdsQueued, + asyncCmdQueues, + asyncCmdProcesses, + ntfNetworkOp, + rcvNetworkOp, + msgDeliveryOp, + sndNetworkOp, + databaseOp, + agentState, + getMsgLocks, + connLocks, + deleteLock, + reconnectLocks, + reconnections, + asyncClients, + agentStats, + clientId, + agentEnv + } agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store @@ -503,7 +540,7 @@ withConnLock AgentClient {connLocks} connId name = withLockMap_ connLocks connId withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pure where - newLock = newEmptyTMVar >>= \l -> TM.insert key l locks $> l + newLock = createLock >>= \l -> TM.insert key l locks $> l withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient msg -> m a) -> m a withClient_ c tSess@(userId, srv, _) statCmd action = do @@ -641,7 +678,8 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do primary = True, dbReplaceQueueId = Nothing, smpClientVersion = maxVersion vRange, - clientNtfCreds = Nothing + clientNtfCreds = Nothing, + deleteErrors = 0 } pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey) @@ -686,6 +724,7 @@ temporaryOrHostError = \case BROKER _ HOST -> True e -> temporaryAgentError e +-- | Subscribe to queues. The list of results can have a different order. subscribeQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())] subscribeQueues c qs = do (errs, qs') <- partitionEithers <$> mapM checkQueue qs @@ -746,11 +785,6 @@ addSubscription c rq@RcvQueue {connId} = atomically $ do RQ.addQueue rq $ activeSubs c RQ.deleteQueue rq $ pendingSubs c -removeQueueSubscription :: MonadIO m => AgentClient -> RcvQueue -> m () -removeQueueSubscription c rq = atomically $ do - RQ.deleteQueue rq $ activeSubs c - RQ.deleteQueue rq $ pendingSubs c - hasActiveSubscription :: AgentClient -> ConnId -> STM Bool hasActiveSubscription c connId = RQ.hasConn connId $ activeSubs c diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index e4cc01678..b596eb374 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -88,6 +88,9 @@ data AgentConfig = AgentConfig messageRetryInterval :: RetryInterval2, messageTimeout :: NominalDiffTime, helloTimeout :: NominalDiffTime, + initialCleanupDelay :: Int, + cleanupInterval :: Int, + deleteErrorCount :: Int, ntfCron :: Word16, ntfWorkerDelay :: Int, ntfSMPWorkerDelay :: Int, @@ -145,6 +148,9 @@ defaultAgentConfig = messageRetryInterval = defaultMessageRetryInterval, messageTimeout = 2 * nominalDay, helloTimeout = 2 * nominalDay, + initialCleanupDelay = 30 * 1000000, -- 30 seconds + cleanupInterval = 30 * 60 * 1000000, -- 30 minutes + deleteErrorCount = 10, ntfCron = 20, -- minutes ntfWorkerDelay = 100000, -- microseconds ntfSMPWorkerDelay = 500000, -- microseconds diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs index eca04d0aa..06b8a9efd 100644 --- a/src/Simplex/Messaging/Agent/Lock.hs +++ b/src/Simplex/Messaging/Agent/Lock.hs @@ -10,6 +10,10 @@ import UnliftIO.STM type Lock = TMVar String +createLock :: STM Lock +createLock = newEmptyTMVar +{-# INLINE createLock #-} + withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a withLock lock name = E.bracket_ diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 7f9f8bb90..6b8f772e8 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -74,7 +74,8 @@ data RcvQueue = RcvQueue -- | SMP client version smpClientVersion :: Version, -- | credentials used in context of notifications - clientNtfCreds :: Maybe ClientNtfCreds + clientNtfCreds :: Maybe ClientNtfCreds, + deleteErrors :: Int } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index ff9eb6329..2196ef512 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -30,6 +30,10 @@ module Simplex.Messaging.Agent.Store.SQLite -- * Users createUserRecord, deleteUserRecord, + setUserDeleted, + deleteUserWithoutConns, + deleteUsersWithoutConns, + checkUser, -- * Queues and connections createNewConn, @@ -38,9 +42,10 @@ module Simplex.Messaging.Agent.Store.SQLite createRcvConn, createSndConn, getConn, - getAnyConn, + getDeletedConn, getConnData, setConnDeleted, + getDeletedConns, getRcvConn, deleteConn, upgradeRcvConnToDuplex, @@ -53,6 +58,7 @@ module Simplex.Messaging.Agent.Store.SQLite setRcvQueuePrimary, setSndQueuePrimary, deleteConnRcvQueue, + incRcvDeleteErrors, deleteConnSndQueue, getPrimaryRcvQueue, getRcvQueue, @@ -306,13 +312,46 @@ createUserRecord db = do DB.execute_ db "INSERT INTO users DEFAULT VALUES" insertedRowId db +checkUser :: DB.Connection -> UserId -> IO (Either StoreError ()) +checkUser db userId = + firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $ + DB.query db "SELECT user_id FROM users WHERE user_id = ? AND deleted = ?" (userId, False) + deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ()) deleteUserRecord db userId = runExceptT $ do - _ :: Only Int64 <- - ExceptT . firstRow id SEUserNotFound $ - DB.query db "SELECT user_id FROM users WHERE user_id = ?" (Only userId) + ExceptT $ checkUser db userId liftIO $ DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) +setUserDeleted :: DB.Connection -> UserId -> IO (Either StoreError [ConnId]) +setUserDeleted db userId = runExceptT $ do + ExceptT $ checkUser db userId + liftIO $ do + DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (True, userId) + map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE user_id = ?" (Only userId) + +deleteUserWithoutConns :: DB.Connection -> UserId -> IO () +deleteUserWithoutConns db userId = + DB.execute + db + [sql| + DELETE FROM users u + WHERE user_id = ? + AND u.deleted = ? + AND NOT EXISTS (SELECT * FROM connections WHERE user_id = u.user_id) + |] + (userId, True) + +deleteUsersWithoutConns :: DB.Connection -> IO () +deleteUsersWithoutConns db = + DB.execute + db + [sql| + DELETE FROM users u + WHERE u.deleted = ? + AND NOT EXISTS (SELECT * FROM connections WHERE user_id = u.user_id) + |] + (Only True) + createConn_ :: TVar ChaChaDRG -> ConnData -> @@ -471,6 +510,10 @@ setSndQueuePrimary db connId SndQueue {dbQueueId} = do "UPDATE snd_queues SET snd_primary = ?, replace_snd_queue_id = ? WHERE conn_id = ? AND snd_queue_id = ?" (True, Nothing :: Maybe Int64, connId, dbQueueId) +incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO () +incRcvDeleteErrors db RcvQueue {connId, dbQueueId} = + DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) + deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO () deleteConnRcvQueue db RcvQueue {connId, dbQueueId} = DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) @@ -1330,10 +1373,13 @@ newQueueId_ (Only maxId : _) = maxId + 1 -- * getConn helpers getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn) -getConn db connId = getAnyConn db connId False +getConn = getAnyConn False -getAnyConn :: DB.Connection -> ConnId -> Bool -> IO (Either StoreError SomeConn) -getAnyConn dbConn connId deleted' = +getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn) +getDeletedConn = getAnyConn True + +getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn) +getAnyConn deleted' dbConn connId = getConnData dbConn connId >>= \case Nothing -> pure $ Left SEConnNotFound Just (cData@ConnData {deleted}, cMode) @@ -1358,6 +1404,9 @@ getConnData dbConn connId' = setConnDeleted :: DB.Connection -> ConnId -> IO () setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId) +getDeletedConns :: DB.Connection -> IO [ConnId] +getDeletedConns db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True) + -- | returns all connection queues, the first queue is the primary one getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue)) getRcvQueuesByConnId_ db connId = @@ -1373,7 +1422,7 @@ rcvQueueQuery = [sql| SELECT c.user_id, s.key_hash, q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.delete_errors, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret FROM rcv_queues q JOIN servers s ON q.host = s.host AND q.port = s.port @@ -1382,16 +1431,16 @@ rcvQueueQuery = toRcvQueue :: (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) - :. (Int64, Bool, Maybe Int64, Maybe Version) + :. (Int64, Bool, Maybe Int64, Maybe Version, Int) :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash smpClientVersion = fromMaybe 1 smpClientVersion_ clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} _ -> Nothing - in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds} + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds, deleteErrors} getRcvQueueById_ :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById_ db connId dbRcvId = diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 994f16590..e7b2322a2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -39,6 +39,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport.Client (TransportHost) @@ -57,7 +58,8 @@ schemaMigrations = ("m20220905_commands", m20220905_commands), ("m20220915_connection_queues", m20220915_connection_queues), ("m20230110_users", m20230110_users), - ("m20230117_fkey_indexes", m20230117_fkey_indexes) + ("m20230117_fkey_indexes", m20230117_fkey_indexes), + ("m20230120_delete_errors", m20230120_delete_errors) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230120_delete_errors.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230120_delete_errors.hs new file mode 100644 index 000000000..918d2dc79 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230120_delete_errors.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230120_delete_errors :: Query +m20230120_delete_errors = + [sql| +PRAGMA ignore_check_constraints=ON; + +ALTER TABLE rcv_queues ADD COLUMN delete_errors INTEGER DEFAULT 0 CHECK (delete_errors NOT NULL); +UPDATE rcv_queues SET delete_errors = 0; + +ALTER TABLE users ADD COLUMN deleted INTEGER DEFAULT 0 CHECK (deleted NOT NULL); +UPDATE users SET deleted = 0; + +PRAGMA ignore_check_constraints=OFF; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 9f1c50e9f..215e410a8 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -47,6 +47,7 @@ CREATE TABLE rcv_queues( rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL), rcv_primary INTEGER CHECK(rcv_primary NOT NULL), replace_rcv_queue_id INTEGER NULL, + delete_errors INTEGER DEFAULT 0 CHECK(delete_errors NOT NULL), PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -230,7 +231,11 @@ CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries( conn_id, snd_queue_id ); -CREATE TABLE users(user_id INTEGER PRIMARY KEY AUTOINCREMENT); +CREATE TABLE users( + user_id INTEGER PRIMARY KEY AUTOINCREMENT + , + deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL) +); CREATE INDEX idx_connections_user ON connections(user_id); CREATE INDEX idx_commands_conn_id ON commands(conn_id); CREATE INDEX idx_commands_host_port ON commands(host, port); diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 07285fd63..e52c151d0 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -670,8 +670,9 @@ testAsyncCommands = do get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False ackMessageAsync alice "7" bobId $ baseId + 4 ("7", _, OK) <- get alice - deleteConnectionAsync alice "8" bobId - ("8", _, OK) <- get alice + deleteConnectionAsync alice bobId + -- deleteConnectionAsync alice "8" bobId + -- ("8", _, OK) <- get alice liftIO $ noMessages alice "nothing else should be delivered to alice" where baseId = 3 @@ -810,9 +811,11 @@ testSwitchDelete servers = do disconnectAgentClient b switchConnectionAsync a "" bId phase a bId QDRcv SPStarted - deleteConnectionAsync a "1" bId - ("1", bId', OK) <- get a - liftIO $ bId `shouldBe` bId' + deleteConnectionAsync a bId + +-- deleteConnectionAsync a "1" bId +-- ("1", bId', OK) <- get a +-- liftIO $ bId `shouldBe` bId' testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int testCreateQueueAuth clnt1 clnt2 = do diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 1636571b6..a43196148 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -168,7 +168,8 @@ rcvQueue1 = primary = True, dbReplaceQueueId = Nothing, smpClientVersion = 1, - clientNtfCreds = Nothing + clientNtfCreds = Nothing, + deleteErrors = 0 } sndQueue1 :: SndQueue @@ -357,7 +358,8 @@ testUpgradeSndConnToDuplex = primary = True, dbReplaceQueueId = Nothing, smpClientVersion = 1, - clientNtfCreds = Nothing + clientNtfCreds = Nothing, + deleteErrors = 0 } upgradeSndConnToDuplex db "conn1" anotherRcvQueue `shouldReturn` Left (SEBadConnType CRcv) From 2ccef1690b0f3848319c5f9087045b7b87d48e9e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 24 Jan 2023 11:12:07 +0000 Subject: [PATCH 16/19] events sent by the agent when queue, connection and user are deleted asynchronously (#619) * events sent by the agent when queue, connection and user are deleted asynchronously * update test * more tests * add user tests * queries Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- src/Simplex/Messaging/Agent.hs | 87 ++++++++++----------- src/Simplex/Messaging/Agent/Protocol.hs | 21 +++++ src/Simplex/Messaging/Agent/Store/SQLite.hs | 51 +++++++----- tests/AgentTests/FunctionalAPITests.hs | 82 +++++++++++++++++-- tests/SMPAgentClient.hs | 2 +- 5 files changed, 167 insertions(+), 76 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 4f52bc3a4..fc8315809 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -129,7 +129,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr, sameSrvAddr') +import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr') import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util @@ -393,9 +393,13 @@ createUser' c srvs = do deleteUser' :: AgentMonad m => AgentClient -> UserId -> Bool -> m () deleteUser' c userId delSMPQueues = do if delSMPQueues - then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ (Just userId) c + then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ delUser c else withStore c (`deleteUserRecord` userId) atomically $ TM.delete userId $ smpServers c + where + delUser = + whenM (withStore' c (`deleteUserWithoutConns` userId)) $ + atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId) newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId newConnAsync c userId corrId enableNtfs cMode = do @@ -467,27 +471,25 @@ deleteConnectionAsync' c connId = withConnLock c connId "deleteConnectionAsync" withStore' c (`setConnDeleted` connId) disableConn c connId void . forkIO $ do - forM_ rqs $ deleteConnQueue c + forM_ rqs $ deleteConnQueue c True delete where - delete = withStore' c (`deleteConn` connId) + delete = do + withStore' c (`deleteConn` connId) + atomically $ writeTBQueue (subQ c) ("", connId, DEL_CONN) deleteConnectionsAsync' :: AgentMonad m => AgentClient -> [ConnId] -> m () -deleteConnectionsAsync' = deleteConnectionsAsync_ Nothing +deleteConnectionsAsync' = deleteConnectionsAsync_ $ pure () -deleteConnectionsAsync_ :: forall m. AgentMonad m => Maybe UserId -> AgentClient -> [ConnId] -> m () -deleteConnectionsAsync_ userId_ c connIds = case connIds of - [] -> delUser +deleteConnectionsAsync_ :: forall m. AgentMonad m => m () -> AgentClient -> [ConnId] -> m () +deleteConnectionsAsync_ onSuccess c connIds = case connIds of + [] -> onSuccess _ -> do (_, rqs, connIds') <- prepareDeleteConnections_ getConn c connIds withStore' c $ forM_ connIds' . setConnDeleted void . forkIO $ - withLock (deleteLock c) "deleteConnectionsAsync" $ do - void $ deleteConnQueues c rqs - delUser - where - delUser :: m () - delUser = forM_ userId_ $ \userId -> withStore' c (`deleteUserWithoutConns` userId) + withLock (deleteLock c) "deleteConnectionsAsync" $ + deleteConnQueues c True rqs >> onSuccess -- | Add connection to the new receive queue switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m () @@ -870,23 +872,8 @@ runCommandProcessing c@AgentClient {subQ} server_ = do secure rq senderKey when (duplexHandshake cData == Just True) . void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO - ICDeleteConn -> - withServer $ \srv -> tryWithLock "ICDeleteConn" $ do - SomeConn _ conn <- withStore c $ \db -> getDeletedConn db connId - case conn of - DuplexConnection _ (rq :| rqs) _ -> delete srv rq $ case rqs of - [] -> notify OK - RcvQueue {server = srv'} : _ -> enqueue srv' - RcvConnection _ rq -> delete srv rq $ notify OK - ContactConnection _ rq -> delete srv rq $ notify OK - _ -> internalErr "command requires connection with rcv queue" - where - delete :: SMPServer -> RcvQueue -> m () -> m () - delete srv rq@RcvQueue {server} next - | sameSrvAddr srv server = deleteConnQueue c rq >> next - | otherwise = enqueue server - enqueue :: SMPServer -> m () - enqueue srv = enqueueCommand c corrId connId (Just srv) $ AInternalCommand ICDeleteConn + -- ICDeleteConn is no longer used, but it can be present in old client databases + ICDeleteConn -> withStore' c (`deleteCommand` cmdId) ICQSecure rId senderKey -> withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) -> case find (sameQueue (srv, rId)) rqs of @@ -1225,7 +1212,7 @@ deleteConnection' c connId = withConnLock c connId "deleteConnection" $ do let rqs = connRcvQueues conn unless (null rqs) $ do disableConn c connId - forM_ rqs $ deleteConnQueue c + forM_ rqs $ deleteConnQueue c False withStore' c (`deleteConn` connId) connRcvQueues :: Connection d -> [RcvQueue] @@ -1236,17 +1223,18 @@ connRcvQueues = \case SndConnection _ _ -> [] NewConnection _ -> [] -deleteConnQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () -deleteConnQueue c rq = do +deleteConnQueue :: AgentMonad m => AgentClient -> Bool -> RcvQueue -> m () +deleteConnQueue c ntf rq = do maxErrs <- asks $ deleteErrorCount . config - deleteQueue c rq `catchError` handleError maxErrs + (deleteQueue c rq >> notify Nothing) `catchError` handleError maxErrs withStore' c (`deleteConnRcvQueue` rq) where handleError maxErrs e | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs = do withStore' c (`incRcvDeleteErrors` rq) throwError e - | otherwise = pure () + | otherwise = notify $ Just e + notify e_ = when ntf $ atomically $ writeTBQueue (subQ c) ("", qConnId rq, DEL_RCVQ (qServer rq) (queueId rq) e_) disableConn :: AgentMonad m => AgentClient -> ConnId -> m () disableConn c connId = do @@ -1256,10 +1244,10 @@ disableConn c connId = do -- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure. deleteConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) -deleteConnections' = deleteConnections_ getConn +deleteConnections' = deleteConnections_ getConn False deleteDeletedConns :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) -deleteDeletedConns = deleteConnections_ getDeletedConn +deleteDeletedConns = deleteConnections_ getDeletedConn True prepareDeleteConnections_ :: forall m. @@ -1284,11 +1272,11 @@ prepareDeleteConnections_ getConnection c connIds = do [] -> Left $ Right () rqs -> Right rqs -deleteConnQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m (Map ConnId (Either AgentErrorType ())) -deleteConnQueues c rqs = do +deleteConnQueues :: forall m. AgentMonad m => AgentClient -> Bool -> [RcvQueue] -> m (Map ConnId (Either AgentErrorType ())) +deleteConnQueues c ntf rqs = do rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs) forM_ (M.assocs rs) $ \case - (connId, Right _) -> withStore' c (`deleteConn` connId) + (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, DEL_CONN) _ -> pure () pure rs where @@ -1297,11 +1285,13 @@ deleteConnQueues c rqs = do maxErrs <- asks $ deleteErrorCount . config forM rs $ \(rq, r) -> do r' <- case r of - Right _ -> withStore' c (`deleteConnRcvQueue` rq) $> r + Right _ -> withStore' c (`deleteConnRcvQueue` rq) >> notifyRQ rq Nothing $> r Left e | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> withStore' c (`incRcvDeleteErrors` rq) $> r - | otherwise -> withStore' c (`deleteConnRcvQueue` rq) $> Right () + | otherwise -> withStore' c (`deleteConnRcvQueue` rq) >> notifyRQ rq (Just e) $> Right () pure (rq, r') + notifyRQ rq e_ = notify ("", qConnId rq, DEL_RCVQ (qServer rq) (queueId rq) e_) + notify = when ntf . atomically . writeTBQueue (subQ c) connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty where @@ -1321,13 +1311,14 @@ deleteConnections_ :: forall m. AgentMonad m => (DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) -> + Bool -> AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) -deleteConnections_ _ _ [] = pure M.empty -deleteConnections_ getConnection c connIds = do +deleteConnections_ _ _ _ [] = pure M.empty +deleteConnections_ getConnection ntf c connIds = do (rs, rqs, _) <- prepareDeleteConnections_ getConnection c connIds - rcvRs <- deleteConnQueues c rqs + rcvRs <- deleteConnQueues c ntf rqs let rs' = M.union rs rcvRs notifyResultError rs' pure rs' @@ -1637,8 +1628,10 @@ cleanupManager c = do void . runExceptT $ withLock (deleteLock c) "cleanupManager" $ do void $ withStore' c getDeletedConns >>= deleteDeletedConns c - withStore' c deleteUsersWithoutConns + withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted threadDelay int + where + notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId) processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m () processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 8f9c833d1..b553ca9bb 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -272,6 +272,9 @@ data ACommand (p :: AParty) where SWCH :: ACommand Client OFF :: ACommand Client DEL :: ACommand Client + DEL_RCVQ :: SMPServer -> SMP.SenderId -> Maybe AgentErrorType -> ACommand Agent + DEL_CONN :: ACommand Agent + DEL_USER :: Int64 -> ACommand Agent CHK :: ACommand Client STAT :: ConnectionStats -> ACommand Agent OK :: ACommand Agent @@ -311,6 +314,9 @@ data ACommandTag (p :: AParty) where SWCH_ :: ACommandTag Client OFF_ :: ACommandTag Client DEL_ :: ACommandTag Client + DEL_RCVQ_ :: ACommandTag Agent + DEL_CONN_ :: ACommandTag Agent + DEL_USER_ :: ACommandTag Agent CHK_ :: ACommandTag Client STAT_ :: ACommandTag Agent OK_ :: ACommandTag Agent @@ -349,6 +355,9 @@ aCommandTag = \case SWCH -> SWCH_ OFF -> OFF_ DEL -> DEL_ + DEL_RCVQ {} -> DEL_RCVQ_ + DEL_CONN -> DEL_CONN_ + DEL_USER _ -> DEL_USER_ CHK -> CHK_ STAT _ -> STAT_ OK -> OK_ @@ -1225,6 +1234,9 @@ instance StrEncoding ACmdTag where "SWCH" -> pure $ ACmdTag SClient SWCH_ "OFF" -> pure $ ACmdTag SClient OFF_ "DEL" -> pure $ ACmdTag SClient DEL_ + "DEL_RCVQ" -> pure $ ACmdTag SAgent DEL_RCVQ_ + "DEL_CONN" -> pure $ ACmdTag SAgent DEL_CONN_ + "DEL_USER" -> pure $ ACmdTag SAgent DEL_USER_ "CHK" -> pure $ ACmdTag SClient CHK_ "STAT" -> pure $ ACmdTag SAgent STAT_ "OK" -> pure $ ACmdTag SAgent OK_ @@ -1260,6 +1272,9 @@ instance APartyI p => StrEncoding (ACommandTag p) where SWCH_ -> "SWCH" OFF_ -> "OFF" DEL_ -> "DEL" + DEL_RCVQ_ -> "DEL_RCVQ" + DEL_CONN_ -> "DEL_CONN" + DEL_USER_ -> "DEL_USER" CHK_ -> "CHK" STAT_ -> "STAT" OK_ -> "OK" @@ -1308,6 +1323,9 @@ commandP binaryP = SENT_ -> s (SENT <$> A.decimal) MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP) MSG_ -> s (MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> binaryP) + DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP) + DEL_CONN_ -> pure DEL_CONN + DEL_USER_ -> s (DEL_USER <$> strP) STAT_ -> s (STAT <$> strP) OK_ -> pure OK ERR_ -> s (ERR <$> strP) @@ -1356,6 +1374,9 @@ serializeCommand = \case SWCH -> s SWCH_ OFF -> s OFF_ DEL -> s DEL_ + DEL_RCVQ srv rcvId err_ -> s (DEL_RCVQ_, srv, rcvId, err_) + DEL_CONN -> s DEL_CONN_ + DEL_USER userId -> s (DEL_USER_, userId) CHK -> s CHK_ STAT srvs -> s (STAT_, srvs) CON -> s CON_ diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 2196ef512..a574d0012 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -329,28 +329,37 @@ setUserDeleted db userId = runExceptT $ do DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (True, userId) map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE user_id = ?" (Only userId) -deleteUserWithoutConns :: DB.Connection -> UserId -> IO () -deleteUserWithoutConns db userId = - DB.execute - db - [sql| - DELETE FROM users u - WHERE user_id = ? - AND u.deleted = ? - AND NOT EXISTS (SELECT * FROM connections WHERE user_id = u.user_id) - |] - (userId, True) +deleteUserWithoutConns :: DB.Connection -> UserId -> IO Bool +deleteUserWithoutConns db userId = do + userId_ :: Maybe Int64 <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT user_id FROM users u + WHERE u.user_id = ? + AND u.deleted = ? + AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) + |] + (userId, True) + case userId_ of + Just _ -> DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) $> True + _ -> pure False -deleteUsersWithoutConns :: DB.Connection -> IO () -deleteUsersWithoutConns db = - DB.execute - db - [sql| - DELETE FROM users u - WHERE u.deleted = ? - AND NOT EXISTS (SELECT * FROM connections WHERE user_id = u.user_id) - |] - (Only True) +deleteUsersWithoutConns :: DB.Connection -> IO [Int64] +deleteUsersWithoutConns db = do + userIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT user_id FROM users u + WHERE u.deleted = ? + AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) + |] + (Only True) + forM_ userIds $ DB.execute db "DELETE FROM users WHERE user_id = ?" . Only + pure userIds createConn_ :: TVar ChaChaDRG -> diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index e52c151d0..f3052ccfe 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module AgentTests.FunctionalAPITests @@ -139,6 +140,13 @@ functionalAPITests t = do testAsyncCommandsRestore t it "should accept connection using async command" $ withSmpServer t testAcceptContactAsync + it "should delete connections using async command when server connection fails" $ + testDeleteConnectionAsync t + describe "Users" $ do + it "should create and delete users with connections" $ + withSmpServer t testUsers + it "should create and delete users with connections when server connection fails" $ + testUsersNoServer t describe "Queue rotation" $ do describe "should switch delivery to the new queue" $ testServerMatrix2 t testSwitchConnection @@ -308,7 +316,7 @@ noMessages c err = tryGet `shouldReturn` () where tryGet = 10000 `timeout` get c >>= \case - Just _ -> error err + Just msg -> error $ err <> ": " <> show msg _ -> return () testAsyncInitiatingOffline :: IO () @@ -671,8 +679,8 @@ testAsyncCommands = do ackMessageAsync alice "7" bobId $ baseId + 4 ("7", _, OK) <- get alice deleteConnectionAsync alice bobId - -- deleteConnectionAsync alice "8" bobId - -- ("8", _, OK) <- get alice + get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False + get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" where baseId = 3 @@ -733,6 +741,66 @@ testAcceptContactAsync = do baseId = 3 msgId = subtract baseId +testDeleteConnectionAsync :: ATransport -> IO () +testDeleteConnectionAsync t = do + a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers + connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing + (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing + (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing + pure ([bId1, bId2, bId3] :: [ConnId]) + runRight_ $ do + deleteConnectionsAsync a connIds + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + liftIO $ noMessages a "nothing else should be delivered to alice" + +testUsers :: IO () +testUsers = do + a <- getSMPAgentClient agentCfg initAgentServers + b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers + runRight_ $ do + (aId, bId) <- makeConnection a b + exchangeGreetingsMsgId 4 a bId b aId + auId <- createUser a [noAuthSrv testSMPServer] + (aId', bId') <- makeConnectionForUsers a auId b 1 + exchangeGreetingsMsgId 4 a bId' b aId' + deleteUser a auId True + get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False + get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False + exchangeGreetingsMsgId 6 a bId b aId + liftIO $ noMessages a "nothing else should be delivered to alice" + +testUsersNoServer :: ATransport -> IO () +testUsersNoServer t = do + a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers + b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers + (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aId, bId) <- makeConnection a b + exchangeGreetingsMsgId 4 a bId b aId + auId <- createUser a [noAuthSrv testSMPServer] + (aId', bId') <- makeConnectionForUsers a auId b 1 + exchangeGreetingsMsgId 4 a bId' b aId' + pure (aId, bId, auId, aId', bId') + get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False + get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False + get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False + runRight_ $ do + deleteUser a auId True + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c == bId'; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False + get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False + liftIO $ noMessages a "nothing else should be delivered to alice" + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False + get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False + exchangeGreetingsMsgId 6 a bId b aId + testSwitchConnection :: InitialAgentServers -> IO () testSwitchConnection servers = do a <- getSMPAgentClient agentCfg servers @@ -812,10 +880,10 @@ testSwitchDelete servers = do switchConnectionAsync a "" bId phase a bId QDRcv SPStarted deleteConnectionAsync a bId - --- deleteConnectionAsync a "1" bId --- ("1", bId', OK) <- get a --- liftIO $ bId `shouldBe` bId' + get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False + liftIO $ noMessages a "nothing else should be delivered to alice" testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int testCreateQueueAuth clnt1 clnt2 = do diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 51782c848..b21554891 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -178,7 +178,7 @@ initAgentServers = InitialAgentServers { smp = userServers [noAuthSrv testSMPServer], ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"], - netCfg = defaultNetworkConfig {tcpTimeout = 500_000} + netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000} } initAgentServers2 :: InitialAgentServers From b59669a65eafeb92d4a986a03e481ecb343ee307 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 24 Jan 2023 13:14:13 +0000 Subject: [PATCH 17/19] refactor functions operating on single connections using batch functions (#620) * refactor functions operating on single connections using batch functions * update tests --- src/Simplex/Messaging/Agent.hs | 75 +++++--------------------- src/Simplex/Messaging/Agent/Client.hs | 16 ------ tests/AgentTests/FunctionalAPITests.hs | 8 +-- 3 files changed, 16 insertions(+), 83 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index fc8315809..d45f15c43 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -90,7 +90,7 @@ module Simplex.Messaging.Agent where import Control.Concurrent.STM (stateTVar) -import Control.Logger.Simple (logInfo, showText) +import Control.Logger.Simple (logError, logInfo, showText) import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader @@ -463,20 +463,7 @@ ackMessageAsync' c corrId connId msgId = do enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () -deleteConnectionAsync' c connId = withConnLock c connId "deleteConnectionAsync" $ do - SomeConn _ conn <- withStore c (`getConn` connId) - case connRcvQueues conn of - [] -> delete - rqs -> do - withStore' c (`setConnDeleted` connId) - disableConn c connId - void . forkIO $ do - forM_ rqs $ deleteConnQueue c True - delete - where - delete = do - withStore' c (`deleteConn` connId) - atomically $ writeTBQueue (subQ c) ("", connId, DEL_CONN) +deleteConnectionAsync' c connId = deleteConnectionsAsync' c [connId] deleteConnectionsAsync' :: AgentMonad m => AgentClient -> [ConnId] -> m () deleteConnectionsAsync' = deleteConnectionsAsync_ $ pure () @@ -627,30 +614,14 @@ rejectContact' c contactConnId invId = withStore c $ \db -> deleteInvitation db contactConnId invId -- | Subscribe to receive connection messages (SUB command) in Reader monad -subscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () -subscribeConnection' c connId = do - SomeConn _ conn <- withStore c (`getConn` connId) - resumeConnCmds c connId - case conn of - DuplexConnection cData (rq :| rqs) sqs -> do - mapM_ (resumeMsgDelivery c cData) sqs - subscribe cData rq - mapM_ (\q -> subscribeQueue c q `catchError` \_ -> pure ()) rqs - SndConnection cData sq -> do - resumeMsgDelivery c cData sq - case status (sq :: SndQueue) of - Confirmed -> pure () - Active -> throwError $ CONN SIMPLEX - _ -> throwError $ INTERNAL "unexpected queue status" - RcvConnection cData rq -> subscribe cData rq - ContactConnection cData rq -> subscribe cData rq - NewConnection _ -> pure () - where - subscribe :: ConnData -> RcvQueue -> m () - subscribe ConnData {enableNtfs} rq = do - subscribeQueue c rq - ns <- asks ntfSupervisor - atomically $ sendNtfSubCommand ns (connId, if enableNtfs then NSCCreate else NSCDelete) +subscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m () +subscribeConnection' c connId = toConnResult connId =<< subscribeConnections' c [connId] + +toConnResult :: AgentMonad m => ConnId -> Map ConnId (Either AgentErrorType ()) -> m () +toConnResult connId rs = case M.lookup connId rs of + Just (Right ()) -> when (M.size rs > 1) $ logError $ T.pack $ "too many results " <> show (M.size rs) + Just (Left e) -> throwError e + _ -> throwError $ INTERNAL $ "no result for connection " <> B.unpack connId type QCmdResult = (QueueStatus, Either AgentErrorType ()) @@ -720,10 +691,7 @@ subscribeConnections' c connIds = do writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m () -resubscribeConnection' c connId = - unlessM - (atomically $ hasActiveSubscription c connId) - (subscribeConnection' c connId) +resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId] resubscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ())) resubscribeConnections' _ [] = pure M.empty @@ -1207,13 +1175,7 @@ suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do -- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure -- currently it is used only in tests deleteConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () -deleteConnection' c connId = withConnLock c connId "deleteConnection" $ do - SomeConn _ conn <- withStore c (`getConn` connId) - let rqs = connRcvQueues conn - unless (null rqs) $ do - disableConn c connId - forM_ rqs $ deleteConnQueue c False - withStore' c (`deleteConn` connId) +deleteConnection' c connId = toConnResult connId =<< deleteConnections' c [connId] connRcvQueues :: Connection d -> [RcvQueue] connRcvQueues = \case @@ -1223,19 +1185,6 @@ connRcvQueues = \case SndConnection _ _ -> [] NewConnection _ -> [] -deleteConnQueue :: AgentMonad m => AgentClient -> Bool -> RcvQueue -> m () -deleteConnQueue c ntf rq = do - maxErrs <- asks $ deleteErrorCount . config - (deleteQueue c rq >> notify Nothing) `catchError` handleError maxErrs - withStore' c (`deleteConnRcvQueue` rq) - where - handleError maxErrs e - | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs = do - withStore' c (`incRcvDeleteErrors` rq) - throwError e - | otherwise = notify $ Just e - notify e_ = when ntf $ atomically $ writeTBQueue (subQ c) ("", qConnId rq, DEL_RCVQ (qServer rq) (queueId rq) e_) - disableConn :: AgentMonad m => AgentClient -> ConnId -> m () disableConn c connId = do atomically $ removeSubscription c connId diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 3975c8d12..b683a2786 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -25,7 +25,6 @@ module Simplex.Messaging.Agent.Client closeProtocolServerClients, runSMPServerTest, newRcvQueue, - subscribeQueue, subscribeQueues, getQueueMessage, decryptSMPMessage, @@ -683,21 +682,6 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do } pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey) -subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () -subscribeQueue c rq@RcvQueue {connId, server, rcvPrivateKey, rcvId} = do - whenM (atomically . TM.member (server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED - atomically $ do - modifyTVar' (subscrConns c) $ S.insert connId - RQ.addQueue rq $ pendingSubs c - r <- withSMPClient c rq "SUB" $ \smp -> - liftIO $ runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq - case r of - Left e -> do - tSess <- mkSMPTransportSession c rq - when (temporaryClientError e) $ reconnectServer c tSess - throwError (protocolClientError SMP (B.unpack $ strEncode server) e) - _ -> pure () - processSubResult :: AgentClient -> RcvQueue -> Either ProtocolClientError () -> IO (Either ProtocolClientError ()) processSubResult c rq r = do case r of diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index f3052ccfe..bdcd1d661 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -751,9 +751,9 @@ testDeleteConnectionAsync t = do pure ([bId1, bId2, bId3] :: [ConnId]) runRight_ $ do deleteConnectionsAsync a connIds - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False @@ -792,7 +792,7 @@ testUsersNoServer t = do get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False runRight_ $ do deleteUser a auId True - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ TIMEOUT))) -> c == bId'; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" From ff038b492c6fcaed702ce3f5d7c90c3623bf9aa5 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Tue, 24 Jan 2023 19:59:32 +0400 Subject: [PATCH 18/19] fix DEL_RCVQ queue parameter type (#621) --- src/Simplex/Messaging/Agent/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index b553ca9bb..39bae0a24 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -272,7 +272,7 @@ data ACommand (p :: AParty) where SWCH :: ACommand Client OFF :: ACommand Client DEL :: ACommand Client - DEL_RCVQ :: SMPServer -> SMP.SenderId -> Maybe AgentErrorType -> ACommand Agent + DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent DEL_CONN :: ACommand Agent DEL_USER :: Int64 -> ACommand Agent CHK :: ACommand Client From 7fb48930f68f68df07ce51c03de8deeff4c04183 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 25 Jan 2023 20:58:03 +0000 Subject: [PATCH 19/19] increase database transaction timeout, add test for user deletion (#622) * increase database transaction timeout, add test for user deletion * more test logs --- src/Simplex/Messaging/Agent/Store/SQLite.hs | 2 +- tests/AgentTests/FunctionalAPITests.hs | 39 ++++++++++++++++++--- 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index a574d0012..a8d7a7bab 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -296,7 +296,7 @@ withConnection SQLiteStore {dbConnection} = (atomically . putTMVar dbConnection) withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a -withTransaction st action = withConnection st $ loop 500 2_000_000 +withTransaction st action = withConnection st $ loop 500 3_000_000 where loop :: Int -> Int -> DB.Connection -> IO a loop t tLim db = diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index bdcd1d661..1a5c9c485 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -143,10 +143,14 @@ functionalAPITests t = do it "should delete connections using async command when server connection fails" $ testDeleteConnectionAsync t describe "Users" $ do - it "should create and delete users with connections" $ + it "should create and delete user with connections" $ withSmpServer t testUsers - it "should create and delete users with connections when server connection fails" $ + it "should create and delete user without connections" $ + withSmpServer t testDeleteUserQuietly + it "should create and delete user with connections when server connection fails" $ testUsersNoServer t + it "should connect two users and switch session mode" $ + withSmpServer t testTwoUsers describe "Queue rotation" $ do describe "should switch delivery to the new queue" $ testServerMatrix2 t testSwitchConnection @@ -193,9 +197,6 @@ functionalAPITests t = do describe "getRatchetAdHash" $ it "should return the same data for both peers" $ withSmpServer t testRatchetAdHash - describe "multiple users" $ - it "should connect two users and switch session mode" $ - withSmpServer t testTwoUsers testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do @@ -776,10 +777,25 @@ testUsers = do exchangeGreetingsMsgId 6 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" +testDeleteUserQuietly :: IO () +testDeleteUserQuietly = do + a <- getSMPAgentClient agentCfg initAgentServers + b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers + runRight_ $ do + (aId, bId) <- makeConnection a b + exchangeGreetingsMsgId 4 a bId b aId + auId <- createUser a [noAuthSrv testSMPServer] + (aId', bId') <- makeConnectionForUsers a auId b 1 + exchangeGreetingsMsgId 4 a bId' b aId' + deleteUser a auId False + exchangeGreetingsMsgId 6 a bId b aId + liftIO $ noMessages a "nothing else should be delivered to alice" + testUsersNoServer :: ATransport -> IO () testUsersNoServer t = do a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers + liftIO $ print 1 (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId @@ -787,18 +803,26 @@ testUsersNoServer t = do (aId', bId') <- makeConnectionForUsers a auId b 1 exchangeGreetingsMsgId 4 a bId' b aId' pure (aId, bId, auId, aId', bId') + liftIO $ print 2 get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False + liftIO $ print 3 runRight_ $ do deleteUser a auId True + liftIO $ print 4 get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False + liftIO $ print 4.1 get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False + liftIO $ print 4.2 get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False + liftIO $ print 5 liftIO $ noMessages a "nothing else should be delivered to alice" withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + liftIO $ print 6 get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False + liftIO $ print 7 exchangeGreetingsMsgId 6 a bId b aId testSwitchConnection :: InitialAgentServers -> IO () @@ -837,21 +861,26 @@ phase c connId d p = testSwitchAsync :: InitialAgentServers -> IO () testSwitchAsync servers = do + liftIO $ print 1 (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId pure (aId, bId) + liftIO $ print 2 let withA' = session withA bId withB' = session withB aId withA' $ \a -> do switchConnectionAsync a "" bId phase a bId QDRcv SPStarted + liftIO $ print 3 withB' $ \b -> phase b aId QDSnd SPStarted withA' $ \a -> phase a bId QDRcv SPConfirmed + liftIO $ print 4 withB' $ \b -> do phase b aId QDSnd SPConfirmed phase b aId QDSnd SPCompleted withA' $ \a -> phase a bId QDRcv SPCompleted + liftIO $ print 5 withA $ \a -> withB $ \b -> runRight_ $ do subscribeConnection a bId subscribeConnection b aId