mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-30 18:04:11 +00:00
access servers via SOCKS proxy (#482)
* access servers via SOCKS proxy * config to pass tcp timeout and option SOCKS5 proxy to the agent
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
e07121266a
commit
d788c3ca95
@@ -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
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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 tlsParams caStore_ host port keyHash keepAliveOpts client = do
|
||||
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_ 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
|
||||
startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
|
||||
connectTLSClient :: forall c. Transport c => (HostName -> ServiceName -> IO Socket) -> HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
|
||||
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
|
||||
ctx <- connectTLS clientParams sock
|
||||
getClientConnection ctx
|
||||
pure sock
|
||||
|
||||
-- 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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user