StreamServer: Support for fall-back bind-addresses.

5 files changed, 47 insertions, 20 deletions

diff --git a/Connection/Tcp.hs b/Connection/Tcp.hs
index a59f35d1..fd5d333b 100644
--- a/Connection/Tcp.hs
+++ b/Connection/Tcp.hs
@@ -303,7 +303,7 @@ server allocate sessionConduits = do
 
     dput XMisc $ "Started listening on "++show port
 
-    sserv <- flip streamServer port ServerConfig
+    sserv <- flip streamServer [port] ServerConfig
         { serverWarn    = dput XMisc
         , serverSession = \sock _ h -> do
             (conkey,u) <- makeConnKey params sock
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 7562f2ad..1d897894 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1675,7 +1675,7 @@ main = do
                 , announcer         = announcer
                 , mbTox             = mbtox
                 }
-        srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
+        srv <- streamServer (withSession session) [SockAddrUnix "dht.sock"]
         return ( do atomically $ readTVar signalQuit >>= check
                     quitListening srv
                , readTVar signalQuit >>= check
diff --git a/examples/toxrelay.hs b/examples/toxrelay.hs
index 953b230b..2743c5d8 100644
--- a/examples/toxrelay.hs
+++ b/examples/toxrelay.hs
@@ -25,6 +25,7 @@ import qualified Data.IntervalSet as IntSet
          ;import Data.IntervalSet (IntSet)
 import Data.Tox.Relay
 import Network.Address (getBindAddress)
+import Network.SocketLike
 import Network.StreamServer
 import Network.Tox (newCrypto)
 import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
@@ -209,18 +210,36 @@ handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
     _ -> return ()
 
 
-main :: IO ()
-main = do
+sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionResponse N1 -> IO ()
+sendTCP_ st addr x = join $ atomically
+    $ IntMap.lookup addr <$> readTVar st >>= \case
+        Nothing   -> return $ return ()
+        Just send -> return $ send $ OnionPacketResponse x
+
+tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionResponse N1 -> IO ())
+tcpRelay udp_addr sendOnion = do
     crypto <- newCrypto
     cons <- newTVarIO Map.empty
-    a <- getBindAddress "33445" True
-    let sendOnion :: SockAddr -> OnionRequest N1 -> IO ()
-        sendOnion _ _ = return ()
+    clients <- newTVarIO IntMap.empty
+    b443   <- getBindAddress "443"   True
+    b80    <- getBindAddress "80"    True
+    b33445 <- getBindAddress "33445" True
+    bany   <- getBindAddress ""      True
     h <- streamServer ServerConfig
                         { serverWarn    = hPutStrLn stderr
                         , serverSession = relaySession crypto cons sendOnion
                         }
-                      a
+                      [b443,b80,udp_addr,b33445,bany]
+    return (h,sendTCP_ clients)
+
+main :: IO ()
+main = do
+    udp_addr <- getBindAddress "33445" True
+    let sendOnion :: SockAddr -> OnionRequest N1 -> IO ()
+        sendOnion _ _ = return ()
+    (h,sendTCP) <- tcpRelay udp_addr sendOnion
+    boundPort <- socketPort $ listenSocket h
+    putStrLn $ "Listening on port: " ++ show boundPort
 
     putStrLn $ "ENTER to quit..."
     s <- getLine
diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
index 82fef126..72a05660 100644
--- a/src/Data/Tox/Relay.hs
+++ b/src/Data/Tox/Relay.hs
@@ -48,7 +48,7 @@ data RelayPacket
     | OnionPacket (OnionRequest N0)
     | OnionPacketResponse (OnionResponse N1)
     -- 0x0A through 0x0F reserved for future use.
-    | RelayData ByteString ConId -- Word8 is a connection id.  Encoded as number 16 to 255.
+    | RelayData ByteString ConId
  deriving (Eq,Ord,Show,Data)
 
 packetNumber :: RelayPacket -> Word8
diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs
index afa35675..80ed4ee2 100644
--- a/src/Network/StreamServer.hs
+++ b/src/Network/StreamServer.hs
@@ -11,6 +11,7 @@ module Network.StreamServer
     , withSession
     , quitListening
     , dummyServerHandle
+    , listenSocket
     ) where
 
 import Data.Monoid
@@ -48,6 +49,8 @@ import DebugTag
 
 data ServerHandle = ServerHandle Socket (Weak ThreadId)
 
+listenSocket :: ServerHandle -> RestrictedSocket
+listenSocket (ServerHandle sock _) = restrictSocket sock
 
 -- | Create a useless do-nothing 'ServerHandle'.
 dummyServerHandle :: IO ServerHandle
@@ -97,20 +100,25 @@ withSession session = ServerConfig warnStderr session
 -- The returned handle can be used with 'quitListening' to terminate the
 -- thread and prevent any new sessions from starting.  Currently active
 -- session threads will not be terminated or signaled in any way.
-streamServer :: ServerConfig -> SockAddr -> IO ServerHandle
-streamServer cfg addr = do
+streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle
+streamServer cfg addrs = do
     let warn   = serverWarn cfg
-        family = case addr of
-                    SockAddrInet  {} -> AF_INET
-                    SockAddrInet6 {} -> AF_INET6
-                    SockAddrUnix  {} -> AF_UNIX
+        family = case addrs of
+                    SockAddrInet  {}:_ -> AF_INET
+                    SockAddrInet6 {}:_ -> AF_INET6
+                    SockAddrUnix  {}:_ -> AF_UNIX
+                    []                 -> AF_INET6
     sock <- socket family Stream 0
     setSocketOption sock ReuseAddr 1
-    fix $ \loop ->
-        tryIOError (removeSocketFile addr) >> bind sock addr
-        `catchIOError` \e -> do warn $ "bind-error: " <> bshow addr <> " " <> bshow e
-                                threadDelay 5000000
-                                loop
+    let tryBind addr next _ = do
+            tryIOError (removeSocketFile addr)
+            bind sock addr
+          `catchIOError` \e -> next (Just e)
+    fix $ \loop -> let again mbe = do
+                            forM_ mbe $ \e -> warn $ "bind-error: " <> bshow addrs <> " " <> bshow e
+                            threadDelay 5000000
+                            loop
+                    in foldr tryBind again addrs Nothing
     listen sock maxListenQueue
     thread <- mkWeakThreadId <=< forkIO $ do
         myThreadId >>= flip labelThread "StreamServer.acceptLoop"