diff --git a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs index 2af86b9a..4cbbd56a 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs @@ -3,6 +3,7 @@ module HBS2.Net.Messaging.TCP ( MessagingTCP , runMessagingTCP , newMessagingTCP + , tcpSOCKS5 , tcpOwnPeer , tcpPeerConn , tcpCookie @@ -12,7 +13,6 @@ module HBS2.Net.Messaging.TCP import HBS2.Clock import HBS2.Net.IP.Addr import HBS2.Net.Messaging -import HBS2.Net.Proto.Types import HBS2.Prelude.Plated import HBS2.Net.Messaging.Stream @@ -20,14 +20,12 @@ import HBS2.Net.Messaging.Stream import HBS2.System.Logger.Simple import Control.Concurrent.STM (flushTQueue) -import Control.Exception (try,Exception,SomeException,throwIO) +import Control.Exception (try,SomeException) import Control.Monad import Data.Bits import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS -import Data.ByteString qualified as BS import Data.Function -import Data.Functor import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as L @@ -37,8 +35,6 @@ import Lens.Micro.Platform import Network.ByteOrder hiding (ByteString) import Network.Simple.TCP import Network.Socket hiding (listen,connect) --- import Network.Socket.ByteString.Lazy hiding (send,recv) -import Streaming.Prelude qualified as S import System.Random hiding (next) import Control.Monad.Trans.Resource @@ -53,7 +49,8 @@ import UnliftIO.Exception qualified as U -- | TCP Messaging environment data MessagingTCP = MessagingTCP - { _tcpOwnPeer :: Peer L4Proto + { _tcpSOCKS5 :: Maybe (PeerAddr L4Proto) + , _tcpOwnPeer :: Peer L4Proto , _tcpCookie :: Word32 , _tcpConnPeer :: TVar (HashMap Word64 (Peer L4Proto)) , _tcpPeerConn :: TVar (HashMap (Peer L4Proto) Word64) @@ -76,18 +73,19 @@ newMessagingTCP :: ( MonadIO m -> m MessagingTCP newMessagingTCP pa = liftIO do - MessagingTCP <$> fromPeerAddr pa - <*> randomIO - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTQueueIO - <*> newTVarIO mempty - <*> newTQueueIO - <*> pure (\_ _ -> none) -- do nothing by default + MessagingTCP Nothing + <$> fromPeerAddr pa + <*> randomIO + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTQueueIO + <*> newTVarIO mempty + <*> newTQueueIO + <*> pure (\_ _ -> none) -- do nothing by default instance Messaging MessagingTCP L4Proto ByteString where @@ -330,9 +328,31 @@ connectPeerTCP env peer = liftIO do pa <- toPeerAddr peer let (L4Address _ (IPAddrPort (i,p))) = pa - connect (show i) (show p) $ \(sock, remoteAddr) -> do - spawnConnection Client env sock remoteAddr - shutdown sock ShutdownBoth + + here <- readTVarIO (view tcpPeerConn env) <&> HashMap.member peer + + unless here do + + case view tcpSOCKS5 env of + Nothing -> do + + connect (show i) (show p) $ \(sock, remoteAddr) -> do + spawnConnection Client env sock remoteAddr + shutdown sock ShutdownBoth + + Just socks5 -> do + + let (L4Address _ (IPAddrPort (socks,socksp))) = socks5 + + connectSOCKS5 (show socks) (show socksp) (show i) (show p) $ \(sock, socksAddr, _) -> do + + let (PeerL4{..}) = peer + + debug $ "CONNECTED VIA SOCKS5" <+> pretty socksAddr <+> pretty pa + + spawnConnection Client env sock _sockAddr + + shutdown sock ShutdownBoth -- FIXME: link-all-asyncs diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 6ae79433..72d7157b 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -134,6 +134,7 @@ data PeerDebugKey data PeerTraceKey data PeerTrace1Key data PeerProxyFetchKey +data PeerTcpSOCKS5 instance Monad m => HasCfgKey PeerDebugKey a m where @@ -157,6 +158,11 @@ instance Monad m => HasCfgKey PeerStorageKey (Maybe String) m where instance Monad m => HasCfgKey PeerProxyFetchKey (Set String) m where key = "proxy-fetch-for" +-- NOTE: socks5-auth +-- Network.Simple.TCP does not support +-- SOCKS5 authentification +instance Monad m => HasCfgKey PeerTcpSOCKS5 (Maybe String) m where + key = "tcp.socks5" data PeerOpts = PeerOpts @@ -586,6 +592,7 @@ runPeer opts = U.handle (\e -> myException e let tcpProbeWait = runReader (cfgValue @PeerTcpProbeWaitKey) syn & fromInteger @(Timeout 'Seconds) . fromMaybe 300 + let useSocks5 = runReader (cfgValue @PeerTcpSOCKS5) syn let listenSa = view listenOn opts <|> listenConf credFile <- pure (view peerCredFile opts <|> keyConf) `orDie` "credentials not set" @@ -684,8 +691,15 @@ runPeer opts = U.handle (\e -> myException e pure (env, (udpAddr, Dispatched env)) tcpPoint <- runMaybeT do + addr <- toMPlus $ fromStringMay @(PeerAddr L4Proto) tcpListen - tcpEnv <- newMessagingTCP addr <&> set tcpOnClientStarted (onClientTCPConnected brains) + + let socks5 = useSocks5 >>= fromStringMay @(PeerAddr L4Proto) + + tcpEnv <- newMessagingTCP addr + <&> set tcpOnClientStarted (onClientTCPConnected brains) + <&> set tcpSOCKS5 socks5 + void $ liftIO ( async do runMessagingTCP tcpEnv `U.withException` \(e :: SomeException) -> do diff --git a/hbs2-peer/examples/config/config b/hbs2-peer/examples/config/config index 79a4d3b1..e12f801d 100644 --- a/hbs2-peer/examples/config/config +++ b/hbs2-peer/examples/config/config @@ -1,20 +1,60 @@ ;; hbs2-peer config file -;; dquotes cause number literals -;; starts from digit! +; listen "0.0.0.0:84" -listen "0.0.0.0:7353" -rpc "127.0.0.1:13333" +; listen "0.0.0.0:7354" + +listen-tcp "tcp://0.0.0.0:3001" + +;; SOCKS5 +;; Warning: login/password auth not supported yet + +tcp.socks5 "127.0.0.1:1080" + +; listen-tcp "tcp://0.0.0.0:45" + +rpc "127.0.0.1:13334" + +; default storage is $HOME/.local/share/hbs2 +;storage "/home/dmz/.local/share/hbs2-anat" + +; edit path to a keyring file key "./key" +brains "/tmp/hbs2-brains.db" -storage "./storage" +accept-block-announce * -;; other parameters +poll reflog 5 "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" -blacklist "G4SPdgMAd3Vvu7fHaDuHSDUAB82nAWnovwaRYdxwvwS1" +;[ validate refchan "Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepG1" +; (socket unix "/tmp/validate-Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepG1") +;] + + +;[ notify refchan "Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP1" +; (socket unix "/tmp/notify-Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP1") +;] + +; known-peer "192.168.1.49:7353" + +; whitelist "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3" +; whitelist "5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf" + +; blacklist "BmjRCrSAu33b9XVhfvku4n8iTcr89Mj1r1tn2un4YmbB" + +http-port 5000 + +http-download on + +trace off + +trace1 off + +debug on + +(rpc unix "/tmp/hbs2-rpc.socket") + +;; debug stuff -;; blacklist "AAh9rjcgg2Zfmd9c8xAhVPBEmUCyYM7wHGxjjqYDZYRb" -;; accept-block-announce * -;; accept-block-announce "AAh9rjcgg2Zfmd9c8xAhVPBEmUCyYM7wHGxjjqYDZYRb"