Support for binding UDP "fake" port to simulate TCP-only connections.

6 files changed, 78 insertions, 13 deletions

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