experimental SOCKS5 support

- no authorization supported (bad for network-tcp-simple)

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
+  MessagingTCP Nothing
-               <*> randomIO
+    <$> fromPeerAddr pa
-               <*> newTVarIO mempty
+    <*> randomIO
-               <*> newTVarIO mempty
+    <*> newTVarIO mempty
-               <*> newTVarIO mempty
+    <*> newTVarIO mempty
-               <*> newTVarIO mempty
+    <*> newTVarIO mempty
-               <*> newTVarIO mempty
+    <*> newTVarIO mempty
-               <*> newTVarIO mempty
+    <*> newTVarIO mempty
-               <*> newTQueueIO
+    <*> newTVarIO mempty
-               <*> newTVarIO mempty
+    <*> newTQueueIO
-               <*> newTQueueIO
+    <*> newTVarIO mempty
-               <*> pure (\_ _ -> none) -- do nothing by default
+    <*> 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
+  here <- readTVarIO (view tcpPeerConn env) <&> HashMap.member peer
-    shutdown sock ShutdownBoth
+
+  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
 

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

hbs2-peer/examples/config/config

@@ -1,20 +1,60 @@
 ;; hbs2-peer config file
 
-;; dquotes cause number literals
+; listen "0.0.0.0:84"
-;; starts from digit!
 
-listen "0.0.0.0:7353"
+; listen "0.0.0.0:7354"
-rpc    "127.0.0.1:13333"
+
+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"