access servers via SOCKS proxy (#482)

* access servers via SOCKS proxy

* config to pass tcp timeout and option SOCKS5 proxy to the agent

apps/smp-agent/Main.hs

@@ -17,7 +17,9 @@ servers :: InitialAgentServers
 servers =
   InitialAgentServers
     { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = []
+      ntf = [],
+      socksProxy = Nothing,
+      tcpTimeout = 5000000
     }
 
 logCfg :: LogConfig

package.yaml

@@ -55,6 +55,7 @@ dependencies:
   - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
+  - socks == 0.6.*
   - sqlite-simple == 0.4.*
   - stm == 2.5.*
   - template-haskell == 2.16.*

rfcs/2022-07-22-access-via-tor.md

@@ -0,0 +1,26 @@
+# Accessing SMP servers via Tor
+
+## Problem
+
+While SMP protocol is focussed on minimizing application-level meta-data by using pair-wise identifiers instead of user profile identifiers, it is important for many users to protect their IP addresses.
+
+Further, even if IP addresses are hidden by onion routing, clients should be able to choose to use a separate TCP connection to subscribe to each queue, even though it increases traffic and battery consumption, as otherwise the servers can observe multiple queues accessed by the same client.
+
+## Solution and requirements
+
+While some users may want to access SMP servers via tor, some other users (even their contacts) may want the opposite - e.g., if they use the network when accessing Tor would be suspicious (or blocked).
+
+Therefore we need to support the connections when one of the user accesses the same server via Tor (and, possibly, via onion address), while another user accesses this server without Tor.
+
+At the same time the user accessing the server via Tor may not want that their contacts access this server without Tor, and it also may be possible that the server is not available under a normal (not .onion) address.
+
+The proposed options for connecting via Tor are:
+
+1. Access servers via Socks proxy: no/yes (specify port?)
+2. Use .onion addresses: no/when available/warn/always
+3. Require senders to use .onion addresses: yes/no
+4. Use separate TCP connection for each queue
+
+While it should be possible for SMP servers to have two addresses (with and without Tor), the queues should only use one server address - if the queue started being accessed via .onion address it should not be possible to access it via a normal address. Queue addresses in connection invitations should support dual server addresses (when senders are not required ot use .onion address).
+
+At the same time, the queue with the normal addresses can be accessed with and without Tor, depending on the current device settings.

simplexmq.cabal

@@ -127,6 +127,7 @@ library
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -188,6 +189,7 @@ executable ntf-server
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -249,6 +251,7 @@ executable smp-agent
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -310,6 +313,7 @@ executable smp-server
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -390,6 +394,7 @@ test-suite smp-server-test
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*

src/Simplex/Messaging/Agent/Client.hs

@@ -91,6 +91,7 @@ import Data.Text.Encoding
 import Data.Tuple (swap)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
+import Network.Socks5 (SocksConf)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
@@ -130,6 +131,8 @@ data AgentClient = AgentClient
     smpClients :: TMap SMPServer SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfServer NtfClientVar,
+    useSocksProxy :: TVar (Maybe SocksConf),
+    useTcpTimeout :: TVar (Int),
     subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
     pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
     subscrConns :: TMap ConnId SMPServer,
@@ -170,7 +173,7 @@ data AgentState = ASActive | ASSuspending | ASSuspended
   deriving (Eq, Show)
 
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
-newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
+newAgentClient InitialAgentServers {smp, ntf, socksProxy, tcpTimeout} agentEnv = do
   let qSize = tbqSize $ config agentEnv
   active <- newTVar True
   rcvQ <- newTBQueue qSize
@@ -180,6 +183,8 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   smpClients <- TM.empty
   ntfServers <- newTVar ntf
   ntfClients <- TM.empty
+  useSocksProxy <- newTVar socksProxy
+  useTcpTimeout <- newTVar tcpTimeout
   subscrSrvrs <- TM.empty
   pendingSubscrSrvrs <- TM.empty
   subscrConns <- TM.empty
@@ -197,7 +202,7 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   asyncClients <- newTVar []
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
   lock <- newTMVar ()
-  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
+  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useSocksProxy, useTcpTimeout, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
 
 agentDbPath :: AgentClient -> FilePath
 agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
@@ -224,7 +229,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
   where
     connectClient :: m SMPClient
     connectClient = do
-      cfg <- asks $ smpCfg . config
+      cfg <- atomically . updateClientConfig c =<< asks (smpCfg . config)
       u <- askUnliftIO
       liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
 
@@ -296,7 +301,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
   where
     connectClient :: m NtfClient
     connectClient = do
-      cfg <- asks $ ntfCfg . config
+      cfg <- atomically . updateClientConfig c =<< asks (ntfCfg . config)
       liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
 
     clientDisconnected :: IO ()
@@ -357,6 +362,12 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
 
+updateClientConfig :: AgentClient -> ProtocolClientConfig -> STM ProtocolClientConfig
+updateClientConfig AgentClient {useSocksProxy, useTcpTimeout} cfg = do
+  socksProxy <- readTVar useSocksProxy
+  tcpTimeout <- readTVar useTcpTimeout
+  pure (cfg :: ProtocolClientConfig) {socksProxy, tcpTimeout}
+
 closeAgentClient :: MonadIO m => AgentClient -> m ()
 closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
@@ -372,7 +383,7 @@ closeAgentClient c = liftIO $ do
   clear smpQueueMsgQueues
   clear getMsgLocks
   where
-    clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
+    clientTimeout sel = (tcpTimeout :: ProtocolClientConfig -> Int) . sel . config $ agentEnv c
     clear :: (AgentClient -> TMap k a) -> IO ()
     clear sel = atomically $ writeTVar (sel c) M.empty
 

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -30,6 +30,7 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
 import Network.Socket
+import Network.Socks5 (SocksConf)
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
@@ -43,6 +44,7 @@ import Simplex.Messaging.Protocol (NtfServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
+import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
@@ -53,7 +55,9 @@ type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorTy
 
 data InitialAgentServers = InitialAgentServers
   { smp :: NonEmpty SMPServer,
-    ntf :: [NtfServer]
+    ntf :: [NtfServer],
+    socksProxy :: Maybe SocksConf,
+    tcpTimeout :: Int
   }
 
 data AgentConfig = AgentConfig
@@ -98,7 +102,7 @@ defaultAgentConfig =
       tbqSize = 64,
       dbFile = "smp-agent.db",
       yesToMigrations = False,
-      smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
+      smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
       reconnectInterval = defaultReconnectInterval,
       helloTimeout = 2 * nominalDay,

src/Simplex/Messaging/Client.hs

@@ -70,6 +70,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Network.Socket (ServiceName)
+import Network.Socks5 (SocksConf)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol as SMP
@@ -118,6 +119,8 @@ data ProtocolClientConfig = ProtocolClientConfig
     tcpTimeout :: Int,
     -- | TCP keep-alive options, Nothing to skip enabling keep-alive
     tcpKeepAlive :: Maybe KeepAliveOpts,
+    -- | use SOCKS5 proxy
+    socksProxy :: Maybe SocksConf,
     -- | period for SMP ping commands (microseconds)
     smpPing :: Int,
     -- | SMP client-server protocol version range
@@ -132,6 +135,7 @@ defaultClientConfig =
       defaultTransport = ("443", transport @TLS),
       tcpTimeout = 5_000_000,
       tcpKeepAlive = Just defaultKeepAliveOpts,
+      socksProxy = Nothing,
       smpPing = 600_000_000, -- 10min
       smpServerVRange = supportedSMPServerVRange
     }
@@ -149,7 +153,7 @@ type Response msg = Either ProtocolClientError msg
 -- 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)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, socksProxy, smpPing, smpServerVRange} msgQ disconnected =
   (atomically mkProtocolClient >>= runClient useTransport)
     `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
   where
@@ -180,7 +184,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
+          runTransportClient socksProxy (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
             `finally` atomically (putTMVar thVar $ Left PCENetworkError)
       th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case th_ of

src/Simplex/Messaging/Protocol.hs

@@ -667,7 +667,7 @@ instance StrEncoding SrvLoc where
   strP = SrvLoc <$> host <*> (port <|> pure "")
     where
       host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
+      port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
 -- | Transmission correlation ID.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)

src/Simplex/Messaging/Transport/Client.hs

@@ -4,6 +4,7 @@ module Simplex.Messaging.Transport.Client
   ( runTransportClient,
     runTLSTransportClient,
     smpClientHandshake,
+    defaultSMPPort,
   )
 where
 
@@ -12,32 +13,43 @@ import Control.Monad.IO.Unlift
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Default (def)
+import Data.Maybe (fromMaybe)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import GHC.IO.Exception (IOErrorType (..))
 import Network.Socket
+import Network.Socks5
 import qualified Network.TLS as T
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
 import System.IO.Error
+import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
 
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: (Transport c, MonadUnliftIO m) => HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTransportClient :: (Transport c, MonadUnliftIO m) => Maybe SocksConf -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
-runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksConf -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ host port keyHash keepAliveOpts client = do
+runTLSTransportClient tlsParams caStore_ socksConf_ host port keyHash keepAliveOpts client = do
   let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash
-  c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
+      connectTCP = maybe connectTCPClient connectSocksClient socksConf_
+  c <- liftIO $ connectTLSClient connectTCP host port clientParams keepAliveOpts
   client c `E.finally` liftIO (closeConnection c)
 
-startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
+connectTLSClient :: forall c. Transport c => (HostName -> ServiceName -> IO Socket) -> HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
-startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
+connectTLSClient tcpClient host port clientParams keepAliveOpts = do
+  sock <- tcpClient host port
+  mapM_ (setSocketKeepAlive sock) keepAliveOpts
+  ctx <- connectTLS clientParams sock
+  getClientConnection ctx
+
+connectTCPClient :: HostName -> ServiceName -> IO Socket
+connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -47,20 +59,24 @@ startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>
       let hints = defaultHints {addrSocketType = Stream}
        in getAddrInfo (Just hints) (Just host) (Just port)
 
-    tryOpen :: IOException -> [AddrInfo] -> IO c
+    tryOpen :: IOException -> [AddrInfo] -> IO Socket
     tryOpen e [] = E.throwIO e
     tryOpen _ (addr : as) =
       E.try (open addr) >>= either (`tryOpen` as) pure
 
-    open :: AddrInfo -> IO c
+    open :: AddrInfo -> IO Socket
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      mapM_ (setSocketKeepAlive sock) keepAliveOpts
+      pure sock
-      ctx <- connectTLS clientParams sock
-      getClientConnection ctx
 
--- readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
+defaultSMPPort :: PortNumber
+defaultSMPPort = 5223
+
+connectSocksClient :: SocksConf -> HostName -> ServiceName -> IO Socket
+connectSocksClient socksProxy host _port = do
+  let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
+  fst <$> socksConnect socksProxy (SocksAddress (SocksAddrDomainName $ B.pack host) port)
 
 mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
 mkTLSClientParams supported caStore_ host port keyHash_ = do

src/Simplex/Messaging/Transport/HTTP2/Client.hs

@@ -122,7 +122,7 @@ sendRequest HTTP2Client {reqQ, config} req = do
 
 runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
 runHTTP2Client tlsParams caStore host port keepAliveOpts client =
-  runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \c ->
+  runTLSTransportClient tlsParams caStore Nothing host port Nothing keepAliveOpts $ \c ->
     withTlsConfig c 16384 (`run` client)
   where
     run = H.run $ ClientConfig "https" (B.pack host) 20

tests/NtfClient.hs

@@ -68,7 +68,7 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 
 testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testNtfClient client =
-  runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+  runTransportClient Nothing testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e

tests/SMPAgentClient.hs

@@ -165,7 +165,9 @@ initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
     { smp = L.fromList [testSMPServer],
-      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
+      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
+      socksProxy = Nothing,
+      tcpTimeout = 5000000
     }
 
 initAgentServers2 :: InitialAgentServers
@@ -215,7 +217,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
 testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
+  runTransportClient Nothing agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
       then client h

tests/SMPClient.hs

@@ -56,7 +56,7 @@ testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 
 testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
 testSMPClient client =
-  runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+  runTransportClient Nothing testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e