dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-14 16:15:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

agent: fail when per-connection transport isolation is used with services (#1670)

Browse Source
This commit is contained in:
Evgeny
2025-11-25 23:17:47 +00:00
committed by GitHub
parent 3ccf854865
commit 5e9b164f4e
11 changed files with 49 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Messaging/Agent.hs
+33 -21
View File
@@ -194,7 +194,7 @@ import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations)
import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration)
import qualified Simplex.Messaging.Agent.TSessionSubs as SS
import Simplex.Messaging.Client (NetworkRequestMode (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
import Simplex.Messaging.Client (NetworkRequestMode (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -249,13 +249,15 @@ import UnliftIO.STM
type AE a = ExceptT AgentErrorType IO a
-- | Creates an SMP agent client instance
getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> Bool -> AE AgentClient
getSMPAgentClient = getSMPAgentClient_ 1
{-# INLINE getSMPAgentClient #-}
getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp, presetServers} store backgroundMode =
newSMPAgentEnv cfg store >>= runReaderT runAgent
getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> Bool -> AE AgentClient
getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp, netCfg, useServices, presetServers} store backgroundMode = do
-- This error should be prevented in the app
when (any id useServices && sessionMode netCfg == TSMEntity) $ throwE $ CMD PROHIBITED "newAgentClient"
liftIO $ newSMPAgentEnv cfg store >>= runReaderT runAgent
where
runAgent = do
liftIO $ checkServers "SMP" smp >> checkServers "XFTP" xftp
@@ -594,18 +596,22 @@ testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of
SPNTF -> runNTFServerTest c nm userId srv
-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
-- TODO [certs rcv] should fail if any user is enabled to use services and per-connection isolation is chosen
setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
setNetworkConfig :: AgentClient -> NetworkConfig -> AE ()
setNetworkConfig c@AgentClient {useNetworkConfig, proxySessTs} cfg' = do
ts <- getCurrentTime
changed <- atomically $ do
(_, cfg) <- readTVar useNetworkConfig
let changed = cfg /= cfg'
!cfgSlow = slowNetworkConfig cfg'
when changed $ writeTVar useNetworkConfig (cfgSlow, cfg')
when (socksProxy cfg /= socksProxy cfg') $ writeTVar proxySessTs ts
pure changed
when changed $ reconnectAllServers c
ts <- liftIO getCurrentTime
(ok, changed) <- atomically $ do
useServices <- readTVar $ useClientServices c
if any id useServices && sessionMode cfg' == TSMEntity
then pure (False, False)
else do
(_, cfg) <- readTVar useNetworkConfig
let changed = cfg /= cfg'
!cfgSlow = slowNetworkConfig cfg'
when changed $ writeTVar useNetworkConfig (cfgSlow, cfg')
when (socksProxy cfg /= socksProxy cfg') $ writeTVar proxySessTs ts
pure (True, changed)
unless ok $ throwE $ CMD PROHIBITED "setNetworkConfig"
when changed $ liftIO $ reconnectAllServers c
setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
setUserNetworkInfo c@AgentClient {userNetworkInfo, userNetworkUpdated} ni = withAgentEnv' c $ do
@@ -772,13 +778,19 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue
whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $
writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId)
-- TODO [certs rcv] should fail enabling if per-connection isolation is set
setUserService' :: AgentClient -> UserId -> Bool -> AM ()
setUserService' c userId enable = do
wasEnabled <- liftIO $ fromMaybe False <$> TM.lookupIO userId (useClientServices c)
when (enable /= wasEnabled) $ do
atomically $ TM.insert userId enable $ useClientServices c
unless enable $ withStore' c (`deleteClientServices` userId)
(ok, changed) <- atomically $ do
(cfg, _) <- readTVar $ useNetworkConfig c
if enable && sessionMode cfg == TSMEntity
then pure (False, False)
else do
wasEnabled <- fromMaybe False <$> TM.lookup userId (useClientServices c)
let changed = enable /= wasEnabled
when changed $ TM.insert userId enable $ useClientServices c
pure (True, changed)
unless ok $ throwE $ CMD PROHIBITED "setNetworkConfig"
when (changed && not enable) $ withStore' c (`deleteClientServices` userId)
newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
src/Simplex/Messaging/Agent/Client.hs
+1 -2
View File
@@ -500,7 +500,6 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
deriving (Eq, Show)
-- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
-- TODO [certs rcv] should fail if both per-connection isolation is set and any users use services
newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do
let cfg = config agentEnv
@@ -749,7 +748,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs, presetDomains} nm
atomically $ SS.setSessionId tSess (sessionId $ thParams smp) $ currentSubs c
updateClientService service smp
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
-- TODO [certs rcv] this should differentiate between service ID just set and service ID changed, and in the latter case disassociate the queue
-- TODO [certs rcv] this should differentiate between service ID just set and service ID changed, and in the latter case disassociate the queues
updateClientService service smp = case (service, smpClientService smp) of
(Just (_, serviceId_), Just THClientService {serviceId})
| serviceId_ /= Just serviceId -> withStore' c $ \db -> setClientServiceId db userId srv serviceId
src/Simplex/Messaging/Agent/Store/AgentStore.hs
-4
View File
@@ -487,7 +487,6 @@ createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode
createNewConn db gVar cData cMode = do
fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode)
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
updateNewConnRcv db connId rq subMode =
getConn db connId $>>= \case
@@ -577,7 +576,6 @@ upgradeRcvConnToDuplex db connId sq =
(SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
(SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
upgradeSndConnToDuplex db connId rq subMode =
getConn db connId >>= \case
@@ -585,7 +583,6 @@ upgradeSndConnToDuplex db connId rq subMode =
Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
_ -> pure $ Left SEConnNotFound
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
addConnRcvQueue db connId rq subMode =
getConn db connId >>= \case
@@ -2500,7 +2497,6 @@ toRcvQueue
(Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
_ -> Nothing
enableNtfs = maybe True unBI enableNtfs_
-- TODO [certs rcv] read client service
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, rcvServiceAssoc, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
-- | returns all connection queue credentials, the first queue is the primary one
src/Simplex/Messaging/Client.hs
+1 -1
View File
@@ -781,7 +781,7 @@ temporaryClientError = \case
smpClientServiceError :: SMPClientError -> Bool
smpClientServiceError = \case
PCEServiceUnavailable -> True
PCETransportError (TEHandshake BAD_SERVICE) -> True -- TODO [certs] this error may be temporary, so we should possibly resubscribe.
PCETransportError (TEHandshake BAD_SERVICE) -> True -- TODO [certs rcv] this error may be temporary, so we should possibly resubscribe.
PCEProtocolError SERVICE -> True
PCEProtocolError (PROXY (BROKER NO_SERVICE)) -> True -- for completeness, it cannot happen.
_ -> False
src/Simplex/Messaging/Notifications/Server.hs
+2 -2
View File
@@ -573,7 +573,7 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
forM_ (L.nonEmpty $ mapMaybe (\(nId, err) -> (nId,) <$> queueSubErrorStatus err) $ L.toList errs) $ \subStatuses -> do
updated <- batchUpdateSrvSubErrors st srv subStatuses
logSubErrors srv subStatuses updated
-- TODO [certs] resubscribe queues with statuses NSErr and NSService
-- TODO [certs rcv] resubscribe queues with statuses NSErr and NSService
CAServiceDisconnected srv serviceSub ->
logNote $ "SMP server service disconnected " <> showService srv serviceSub
CAServiceSubscribed srv serviceSub@(ServiceSub _ expected _) (ServiceSub _ n _) -- TODO [certs rcv] compare hash
@@ -603,7 +603,7 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
queueSubErrorStatus :: SMPClientError -> Maybe NtfSubStatus
queueSubErrorStatus = \case
PCEProtocolError AUTH -> Just NSAuth
-- TODO [certs] we could allow making individual subscriptions within service session to handle SERVICE error.
-- TODO [certs rcv] we could allow making individual subscriptions within service session to handle SERVICE error.
-- This would require full stack changes in SMP server, SMP client and SMP service agent.
PCEProtocolError SERVICE -> Just NSService
PCEProtocolError e -> updateErr "SMP error " e
src/Simplex/Messaging/Server.hs
+1 -1
View File
@@ -923,7 +923,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
putSubscribersInfo protoName ServerSubscribers {queueSubscribers, subClients} showIds = do
activeSubs <- getSubscribedClients queueSubscribers
hPutStrLn h $ protoName <> " subscriptions: " <> show (M.size activeSubs)
-- TODO [certs] service subscriptions
-- TODO [certs rcv] service subscriptions
clnts <- countSubClients activeSubs
hPutStrLn h $ protoName <> " subscribed clients: " <> show (IS.size clnts) <> (if showIds then " " <> show (IS.toList clnts) else "")
clnts' <- readTVarIO subClients
src/Simplex/Messaging/Server/Main.hs
+1 -1
View File
@@ -556,7 +556,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
mkTransportServerConfig
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
(Just $ alpnSupportedSMPHandshakes <> httpALPN)
(fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option
(fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs rcv] remove this option
controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
smpAgentCfg =
defaultSMPClientAgentConfig
src/Simplex/Messaging/Transport.hs
+1 -1
View File
@@ -560,7 +560,7 @@ data SMPClientHandshake = SMPClientHandshake
keyHash :: C.KeyHash,
-- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
authPubKey :: Maybe C.PublicKeyX25519,
-- TODO [certs] remove proxyServer, as serviceInfo includes it as clientRole
-- TODO [certs rcv] remove proxyServer, as serviceInfo includes it as clientRole
-- | Whether connecting client is a proxy server (send from SMP v12).
-- This property, if True, disables additional transport encrytion inside TLS.
-- (Proxy server connection already has additional encryption, so this layer is not needed there).
tests/AgentTests/FunctionalAPITests.hs
+5 -5
View File
@@ -3607,7 +3607,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
exchangeGreetings a bId1' b aId1'
a `hasClients` 1
b `hasClients` 1
liftIO $ setNetworkConfig a nc {sessionMode = TSMEntity}
setNetworkConfig a nc {sessionMode = TSMEntity}
liftIO $ threadDelay 250000
("", "", DOWN _ _) <- nGet a
("", "", UP _ _) <- nGet a
@@ -3617,7 +3617,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
exchangeGreetingsMsgId 4 a bId1 b aId1
exchangeGreetingsMsgId 4 a bId1' b aId1'
liftIO $ threadDelay 250000
liftIO $ setNetworkConfig a nc {sessionMode = TSMUser}
setNetworkConfig a nc {sessionMode = TSMUser}
liftIO $ threadDelay 250000
("", "", DOWN _ _) <- nGet a
("", "", DOWN _ _) <- nGet a
@@ -3632,7 +3632,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
exchangeGreetings a bId2' b aId2'
a `hasClients` 2
b `hasClients` 1
liftIO $ setNetworkConfig a nc {sessionMode = TSMEntity}
setNetworkConfig a nc {sessionMode = TSMEntity}
liftIO $ threadDelay 250000
("", "", DOWN _ _) <- nGet a
("", "", DOWN _ _) <- nGet a
@@ -3646,7 +3646,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
exchangeGreetingsMsgId 4 a bId2 b aId2
exchangeGreetingsMsgId 4 a bId2' b aId2'
liftIO $ threadDelay 250000
liftIO $ setNetworkConfig a nc {sessionMode = TSMUser}
setNetworkConfig a nc {sessionMode = TSMUser}
liftIO $ threadDelay 250000
("", "", DOWN _ _) <- nGet a
("", "", DOWN _ _) <- nGet a
@@ -3695,7 +3695,7 @@ testClientServiceConnection ps = do
getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> String -> IO AgentClient
getSMPAgentClient' clientId cfg' initServers dbPath = do
Right st <- liftIO $ createStore dbPath
c <- getSMPAgentClient_ clientId cfg' initServers st False
Right c <- runExceptT $ getSMPAgentClient_ clientId cfg' initServers st False
when (dbNew st) $ insertUser st
pure c
tests/CoreTests/BatchingTests.hs
+1 -1
View File
@@ -334,7 +334,7 @@ randomSUBv6 = randomSUB_ C.SEd25519 minServerSMPRelayVersion
randomSUB :: ByteString -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
randomSUB = randomSUB_ C.SEd25519 currentClientSMPRelayVersion
-- TODO [certs] test with the additional certificate signature
-- TODO [certs rcv] test with the additional certificate signature
randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
randomSUB_ a v sessId = do
g <- C.newRandom
tests/ServerTests.hs
+3 -3
View File
@@ -714,7 +714,7 @@ testServiceDeliverSubscribe =
runSMPServiceClient t (tlsCred, serviceKeys) $ \sh -> do
let idsHash = queueIdsHash [rId]
Resp "10" NoEntity (ERR (CMD NO_AUTH)) <- signSendRecv sh aServicePK ("10", NoEntity, SUBS 1 idsHash)
signSend_ sh aServicePK Nothing ("11", serviceId, SUBS 1 idsHash) -- TODO [certs rcv] compute and compare hashes
signSend_ sh aServicePK Nothing ("11", serviceId, SUBS 1 idsHash)
[mId3] <-
fmap catMaybes $
receiveInAnyOrder -- race between SOKS and MSG, clients can handle it
@@ -808,7 +808,7 @@ testServiceUpgradeAndDowngrade =
runSMPServiceClient t (tlsCred, serviceKeys) $ \sh -> do
let idsHash = queueIdsHash [rId, rId2, rId3]
signSend_ sh aServicePK Nothing ("14", serviceId, SUBS 3 idsHash) -- TODO [certs rcv] compute hash
signSend_ sh aServicePK Nothing ("14", serviceId, SUBS 3 idsHash)
[(rKey3_1, rId3_1, mId3_1), (rKey3_2, rId3_2, mId3_2)] <-
fmap catMaybes $
receiveInAnyOrder -- race between SOKS and MSG, clients can handle it
@@ -1371,7 +1371,7 @@ testMessageServiceNotifications =
deliverMessage rh rId'' rKey'' sh sId'' sKey'' nh2 "connection 2" dec''
-- -- another client makes service subscription
let idsHash = queueIdsHash [nId', nId'']
Resp "12" serviceId5 (SOKS 2 idsHash') <- signSendRecv nh1 (C.APrivateAuthKey C.SEd25519 servicePK) ("12", serviceId, NSUBS 2 idsHash) -- TODO [certs rcv] compute and compare hashes
Resp "12" serviceId5 (SOKS 2 idsHash') <- signSendRecv nh1 (C.APrivateAuthKey C.SEd25519 servicePK) ("12", serviceId, NSUBS 2 idsHash)
idsHash' `shouldBe` idsHash
serviceId5 `shouldBe` serviceId
Resp "" serviceId6 (ENDS 2) <- tGet1 nh2