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

3 files changed, 59 insertions, 1 deletions

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