From 778114bb6c644c496859e8281e96d5e44661e183 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 9 Jan 2020 14:04:37 -0500 Subject: Support for binding UDP "fake" port to simulate TCP-only connections. --- dht/examples/dhtd.hs | 11 ++++++++-- dht/src/Network/BitTorrent/MainlineDHT.hs | 7 +++--- dht/src/Network/Tox.hs | 13 ++++++----- server/server.cabal | 15 ++++++++++++- server/src/Network/Bind.hs | 36 +++++++++++++++++++++++++++++++ server/src/Network/QueryResponse.hs | 9 ++++++++ 6 files changed, 78 insertions(+), 13 deletions(-) create mode 100644 server/src/Network/Bind.hs diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs index 2f39303c..ed0feacb 100644 --- a/dht/examples/dhtd.hs +++ b/dht/examples/dhtd.hs @@ -38,6 +38,7 @@ import qualified Data.Conduit.List as C import Data.Data import Data.Dependent.Sum import Data.Function +import Data.Functor import Data.Functor.Identity import Data.Hashable import Data.List @@ -71,6 +72,7 @@ import qualified Data.Tox.DHT.Multi as Multi import DebugUtil import Network.UPNP as UPNP import Network.Address hiding (NodeId, NodeInfo(..)) +import Network.Bind as Bind import Network.QueryResponse import qualified Network.QueryResponse.TCP as TCP import Network.StreamServer @@ -1771,8 +1773,13 @@ main = do (quitBt,btdhts,btips,baddrs) <- case portbt opts of "" -> return (return (), Map.empty,return [],[]) p -> do - addr <- getBindAddress p (ip6bt opts) - (bt,btR,btBootstrap4, btBootstrap6,quitBtClient) <- Mainline.newClient swarms addr + msock <- Bind.udpTransport' (ip6bt opts) [p,"0"] + let bail = do + dput XMisc $ "Bittorrent DHT disabled. Unable to bind bittorrent dht port: " ++ p + return (return (), Map.empty, return [], []) + fromMaybe bail $ msock <&> \(udp,sock) -> do + addr <- getSocketName sock + (bt,btR,btBootstrap4, btBootstrap6,quitBtClient) <- Mainline.newClient swarms addr udp quitBt <- forkListener "bt" (clientNet bt) mainlineSearches <- atomically $ newTVar Map.empty peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port. diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs index d3904c40..a83cf740 100644 --- a/dht/src/Network/BitTorrent/MainlineDHT.hs +++ b/dht/src/Network/BitTorrent/MainlineDHT.hs @@ -545,15 +545,16 @@ mkNodeInfo nid addr = NodeInfo , nodePort = fromMaybe 0 $ sockAddrPort addr } -newClient :: SwarmsDatabase -> SockAddr +newClient :: SwarmsDatabase + -> SockAddr -- ^ Tentative IP address for this node (the bind address is suitable). + -> Transport String SockAddr ByteString -- ^ UDP transport -> IO ( MainlineClient , Routing , [NodeInfo] -> [NodeInfo] -> IO () , [NodeInfo] -> [NodeInfo] -> IO () , IO () ) -newClient swarms addr = do - udp <- udpTransport addr +newClient swarms addr udp = do nid <- NodeId <$> getRandomBytes 20 let tentative_info = mkNodeInfo nid addr tentative_info6 <- diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs index 4aed1c43..270a9036 100644 --- a/dht/src/Network/Tox.hs +++ b/dht/src/Network/Tox.hs @@ -36,6 +36,7 @@ import qualified Data.ByteString.Char8 as C8 import Data.Data import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum +import Data.Functor import Data.Functor.Identity import Data.Functor.Contravariant import Data.Maybe @@ -56,6 +57,7 @@ import qualified Data.Word64Map (empty) ;import Data.Word64Map (fitsInInt) import qualified Data.Wrapper.PSQ as PSQ import Network.Address (IP, WantIP (..), getBindAddress) +import Network.Bind as Bind import Network.BitTorrent.DHT.Token as Token import Network.Kademlia.Bootstrap (bootstrap, forkPollForRefresh) import qualified Network.Kademlia.Routing as R @@ -262,14 +264,11 @@ newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rende -- ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. XXX ignored -> IO (Tox extra) newTox keydb bindspecs onsess crypto usetcp = do - addrs <- mapM (`getBindAddress` True) bindspecs - let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just) - failedBind mbe = do - forM_ mbe $ \e -> do - dput XDHT $ "tox udp bind error: " ++ show addrs ++ " " ++ show e - throwIO e + msock <- Bind.udpTransport' True bindspecs + let failedBind = do + dput XDHT $ "tox udp bind error: " ++ show bindspecs throwIO $ userError "Tox UDP listen port?" - (udp,sock) <- foldr tryBind failedBind addrs Nothing + fromMaybe failedBind $ msock <&> \(udp,sock) -> do addr <- getSocketName sock dput XOnion $ "UDP bind address: " ++ show addr (relay,sendTCP) <- diff --git a/server/server.cabal b/server/server.cabal index 44441ef1..b5a36f91 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -31,7 +31,20 @@ flag new-network-bsd library - exposed-modules: Network.QueryResponse, Network.StreamServer, Network.SocketLike, Network.QueryResponse.TCP, Data.TableMethods, Connection.Tcp, Control.Concurrent.Delay, DNSCache, GetHostByAddr, ControlMaybe, SockAddr, Control.Concurrent.PingMachine, Connection + exposed-modules: Network.QueryResponse + , Network.StreamServer + , Network.SocketLike + , Network.QueryResponse.TCP + , Network.Bind + , Data.TableMethods + , Connection.Tcp + , Control.Concurrent.Delay + , DNSCache + , GetHostByAddr + , ControlMaybe + , SockAddr + , Control.Concurrent.PingMachine + , Connection other-modules: ForkLabeled, DebugTag other-extensions: CPP, GADTs, LambdaCase, PartialTypeSignatures, RankNTypes, ScopedTypeVariables, TupleSections, TypeFamilies, TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving, DoAndIfThenElse, FlexibleInstances, StandaloneDeriving build-depends: base, stm, bytestring, dependent-map, dependent-sum, contravariant, containers, time, cpu, dput-hslogger, directory, lifted-base, hashable, conduit, text, psq-wrap, minmax-psq, lifted-concurrent, word64-map, network-addr diff --git a/server/src/Network/Bind.hs b/server/src/Network/Bind.hs new file mode 100644 index 00000000..d2442c82 --- /dev/null +++ b/server/src/Network/Bind.hs @@ -0,0 +1,36 @@ +module Network.Bind where + +import Data.ByteString (ByteString) +import Network.Socket +import System.IO.Error + +import Network.Address (getBindAddress) +import qualified Network.QueryResponse as QR + ;import Network.QueryResponse hiding (udpTransport, udpTransport') + +-- | Try (in order) a list of port numbers to bind a socket on and return a +-- 'Transport' on the first success. +-- +-- Port numbers may be specified symbolically (for example, "domain" for port +-- 53) and additionally, for testing convenience, the port "fake" will pretend +-- to bind a port but instead return a null transport. +-- +-- The Bool argument should be 'True' if you want a dual-socket that supports +-- both IPv4 and IPv6. Otherwise, IPv4 only will be assumed. +udpTransport' :: Show err => Bool -> [String] -> IO (Maybe (Transport err SockAddr ByteString, Socket)) +udpTransport' want6 ports = do + let tryBind "fake" _ = do + dummysock <- socket (if want6 then AF_INET6 else AF_INET) Datagram defaultProtocol + return $ Just (QR.nullTransport, dummysock) + tryBind port next = do + addr <- getBindAddress port want6 + (udp,sock) <- QR.udpTransport' addr + return $ Just (udp,sock) + `catchIOError` \e -> do + -- warn $ "bind-error: " <> bshow addr <> " " <> bshow e + next + foldr tryBind (return Nothing) ports + +-- | Like "udpTransport\'" except that it does not return the bound 'Socket'. +udpTransport :: Show err => Bool -> [String] -> IO (Maybe (Transport err SockAddr ByteString)) +udpTransport want6 ports = fmap fst <$> udpTransport' want6 ports diff --git a/server/src/Network/QueryResponse.hs b/server/src/Network/QueryResponse.hs index 94eb4796..470b7ce7 100644 --- a/server/src/Network/QueryResponse.hs +++ b/server/src/Network/QueryResponse.hs @@ -81,6 +81,13 @@ data TransportA err addr x y = Transport type Transport err addr x = TransportA err addr x x +nullTransport :: TransportA err addr x y +nullTransport = Transport + { awaitMessage = \_ -> retry + , sendMessage = \_ _ -> return () + , setActive = \_ -> return () + } + closeTransport :: TransportA err addr x y -> IO () closeTransport tr = setActive tr False @@ -606,6 +613,8 @@ saferSendTo sock bs saddr = void (B.sendTo sock bs saddr) else throw e -- | Like 'udpTransport' except also returns the raw socket (for broadcast use). +-- +-- Note: Throws an exception if unable to bind. udpTransport' :: Show err => SockAddr -> IO (Transport err SockAddr ByteString, Socket) udpTransport' bind_address = do let family = sockAddrFamily bind_address -- cgit v1.2.3