From 6047a311f270bbb0a176900d9b1fea5e6d9b96c1 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Sat, 4 Jan 2020 17:23:46 -0500
Subject: TCP relay server now binds to UDP node port as fallback.

---
 dht/src/Network/Tox/Relay.hs        |  2 +-
 network-addr/network-addr.cabal     |  1 +
 network-addr/src/Network/Address.hs | 13 +++++++++++++
 server/src/DNSCache.hs              |  5 +----
 server/src/Network/StreamServer.hs  | 24 +++++++++++++++---------
 5 files changed, 31 insertions(+), 14 deletions(-)

diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs
index 2ecd7ddf..3aa596ab 100644
--- a/dht/src/Network/Tox/Relay.hs
+++ b/dht/src/Network/Tox/Relay.hs
@@ -252,7 +252,7 @@ tcpRelay crypto udp_addr sendOnion = do
     b33445 <- getBindAddress "33445" True
     bany   <- getBindAddress ""      True
     h <- streamServer ServerConfig
-                        { serverWarn    = hPutStrLn stderr
+                        { serverWarn    = dput XOnion
                         , serverSession = relaySession crypto clients cons sendOnion
                         }
                       [b443,b80,b3389,udp_addr,b33445,bany]
diff --git a/network-addr/network-addr.cabal b/network-addr/network-addr.cabal
index 5cbd9130..72886503 100644
--- a/network-addr/network-addr.cabal
+++ b/network-addr/network-addr.cabal
@@ -37,6 +37,7 @@ library
   build-depends:
           base
         , bytestring
+        , cpu
         , time
         , pretty
         , iproute
diff --git a/network-addr/src/Network/Address.hs b/network-addr/src/Network/Address.hs
index 9cfbbb40..57bb11d1 100644
--- a/network-addr/src/Network/Address.hs
+++ b/network-addr/src/Network/Address.hs
@@ -41,6 +41,8 @@ module Network.Address
        , ipFamily
        , is4mapped
        , either4or6
+       , make6mapped4
+       , canonize
 
          -- * PeerId
          -- $peer-id
@@ -132,6 +134,7 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
 #if !MIN_VERSION_time(1,5,0)
 import System.Locale    (defaultTimeLocale)
 #endif
+import System.Endian (fromBE32)
 import System.Entropy
 import DPut
 import DebugTag
@@ -1242,6 +1245,16 @@ either4or6 a6@(SockAddrInet6 port _ addr _)
     | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4)
     | otherwise                                = Right a6
 
+make6mapped4 :: SockAddr -> SockAddr
+make6mapped4 addr@(SockAddrInet6 {}) = addr
+make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
+
+canonize :: SockAddr -> SockAddr
+canonize a6@(SockAddrInet6 port _ addr _)
+    | Just ip4 <- (fromSockAddr a6 >>= un4map) = setPort port $ toSockAddr ip4
+canonize a = a
+
+
 data WantIP = Want_IP4 | Want_IP6 | Want_Both
  deriving (Eq, Enum, Ord, Show)
 
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
-- 
cgit v1.2.3