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

2 files changed, 45 insertions, 0 deletions

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