TCP relay server now binds to UDP node port as fallback.

2 files changed, 16 insertions, 13 deletions

diff --git a/server/src/DNSCache.hs b/server/src/DNSCache.hs
index f539c71f..225584e3 100644
--- a/server/src/DNSCache.hs
+++ b/server/src/DNSCache.hs
@@ -50,6 +50,7 @@ import GetHostByAddr ( getHostByAddr )
 import Control.Concurrent.Delay
 import DPut
 import DebugTag
+import Network.Address (make6mapped4)
 
 type TimeStamp = UTCTime
 
@@ -100,10 +101,6 @@ dnsObserve dns withScrub utc obs = do
     updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f
     updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r
 
-make6mapped4 :: SockAddr -> SockAddr
-make6mapped4 addr@(SockAddrInet6 {}) = addr
-make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
-
 tryForkOS :: String -> IO () -> IO ThreadId
 tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do
     dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out."
diff --git a/server/src/Network/StreamServer.hs b/server/src/Network/StreamServer.hs
index 1da612ce..4fc477c5 100644
--- a/server/src/Network/StreamServer.hs
+++ b/server/src/Network/StreamServer.hs
@@ -46,6 +46,7 @@ import System.IO.Error
 import System.IO (Handle)
 import Control.Concurrent.MVar (newMVar)
 
+import Network.Address (make6mapped4, canonize)
 import Network.SocketLike
 import DPut
 import DebugTag
@@ -113,24 +114,29 @@ withSession session = ServerConfig warnStderr session
 -- 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 addrs = do
+streamServer cfg addrs0 = do
     let warn   = serverWarn cfg
-        family = case addrs of
+        family = case addrs0 of
                     SockAddrInet  {}:_ -> AF_INET
                     SockAddrInet6 {}:_ -> AF_INET6
                     SockAddrUnix  {}:_ -> AF_UNIX
                     []                 -> AF_INET6
+        addrs = map (if family == AF_INET6 then make6mapped4 else canonize) addrs0
     sock <- socket family Stream 0
     setSocketOption sock ReuseAddr 1
-    let tryBind addr next _ = do
+    let tryBind addr next = do
+            warn $ "Trying to bind to TCP " ++ show addr
             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
+            return $ Just addr
+          `catchIOError` \e -> do
+            warn $ "bind-error: " <> bshow addr <> " " <> bshow e
+            next
+    bound <- fix $ \loop -> do
+            m <- foldr tryBind (return Nothing) addrs
+            case m of
+                Just a  -> return a
+                Nothing -> threadDelay 5000000 >> loop
     listen sock maxListenQueue
     thread <- mkWeakThreadId <=< forkIO $ do
         bindaddr <- Socket.getSocketName sock