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

Author: epoberezkin

src/Simplex/Messaging/Agent.hs

@@ -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

@@ -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

@@ -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,15 +576,13 @@ 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
     Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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