mirror of https://github.com/voidlizard/hbs2
experimental SOCKS5 support
- no authorization supported (bad for network-tcp-simple)
This commit is contained in:
Dmitry Zuikov
parent
0a55f1a732
commit
58d0e9d256
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue