diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-04 17:23:46 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-04 17:23:46 -0500 |
commit | 6047a311f270bbb0a176900d9b1fea5e6d9b96c1 (patch) | |
tree | f3e52431dad452118a7ebde5c383f4f5abef726c | |
parent | 5181c77ce7dd73d622ff3921b90bf2741bedb646 (diff) |
TCP relay server now binds to UDP node port as fallback.
-rw-r--r-- | dht/src/Network/Tox/Relay.hs | 2 | ||||
-rw-r--r-- | network-addr/network-addr.cabal | 1 | ||||
-rw-r--r-- | network-addr/src/Network/Address.hs | 13 | ||||
-rw-r--r-- | server/src/DNSCache.hs | 5 | ||||
-rw-r--r-- | 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 | |||
252 | b33445 <- getBindAddress "33445" True | 252 | b33445 <- getBindAddress "33445" True |
253 | bany <- getBindAddress "" True | 253 | bany <- getBindAddress "" True |
254 | h <- streamServer ServerConfig | 254 | h <- streamServer ServerConfig |
255 | { serverWarn = hPutStrLn stderr | 255 | { serverWarn = dput XOnion |
256 | , serverSession = relaySession crypto clients cons sendOnion | 256 | , serverSession = relaySession crypto clients cons sendOnion |
257 | } | 257 | } |
258 | [b443,b80,b3389,udp_addr,b33445,bany] | 258 | [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 | |||
37 | build-depends: | 37 | build-depends: |
38 | base | 38 | base |
39 | , bytestring | 39 | , bytestring |
40 | , cpu | ||
40 | , time | 41 | , time |
41 | , pretty | 42 | , pretty |
42 | , iproute | 43 | , 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 | |||
41 | , ipFamily | 41 | , ipFamily |
42 | , is4mapped | 42 | , is4mapped |
43 | , either4or6 | 43 | , either4or6 |
44 | , make6mapped4 | ||
45 | , canonize | ||
44 | 46 | ||
45 | -- * PeerId | 47 | -- * PeerId |
46 | -- $peer-id | 48 | -- $peer-id |
@@ -132,6 +134,7 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) | |||
132 | #if !MIN_VERSION_time(1,5,0) | 134 | #if !MIN_VERSION_time(1,5,0) |
133 | import System.Locale (defaultTimeLocale) | 135 | import System.Locale (defaultTimeLocale) |
134 | #endif | 136 | #endif |
137 | import System.Endian (fromBE32) | ||
135 | import System.Entropy | 138 | import System.Entropy |
136 | import DPut | 139 | import DPut |
137 | import DebugTag | 140 | import DebugTag |
@@ -1242,6 +1245,16 @@ either4or6 a6@(SockAddrInet6 port _ addr _) | |||
1242 | | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4) | 1245 | | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4) |
1243 | | otherwise = Right a6 | 1246 | | otherwise = Right a6 |
1244 | 1247 | ||
1248 | make6mapped4 :: SockAddr -> SockAddr | ||
1249 | make6mapped4 addr@(SockAddrInet6 {}) = addr | ||
1250 | make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0 | ||
1251 | |||
1252 | canonize :: SockAddr -> SockAddr | ||
1253 | canonize a6@(SockAddrInet6 port _ addr _) | ||
1254 | | Just ip4 <- (fromSockAddr a6 >>= un4map) = setPort port $ toSockAddr ip4 | ||
1255 | canonize a = a | ||
1256 | |||
1257 | |||
1245 | data WantIP = Want_IP4 | Want_IP6 | Want_Both | 1258 | data WantIP = Want_IP4 | Want_IP6 | Want_Both |
1246 | deriving (Eq, Enum, Ord, Show) | 1259 | deriving (Eq, Enum, Ord, Show) |
1247 | 1260 | ||
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 ) | |||
50 | import Control.Concurrent.Delay | 50 | import Control.Concurrent.Delay |
51 | import DPut | 51 | import DPut |
52 | import DebugTag | 52 | import DebugTag |
53 | import Network.Address (make6mapped4) | ||
53 | 54 | ||
54 | type TimeStamp = UTCTime | 55 | type TimeStamp = UTCTime |
55 | 56 | ||
@@ -100,10 +101,6 @@ dnsObserve dns withScrub utc obs = do | |||
100 | updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f | 101 | updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f |
101 | updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r | 102 | updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r |
102 | 103 | ||
103 | make6mapped4 :: SockAddr -> SockAddr | ||
104 | make6mapped4 addr@(SockAddrInet6 {}) = addr | ||
105 | make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0 | ||
106 | |||
107 | tryForkOS :: String -> IO () -> IO ThreadId | 104 | tryForkOS :: String -> IO () -> IO ThreadId |
108 | tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do | 105 | tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do |
109 | dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out." | 106 | 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 | |||
46 | import System.IO (Handle) | 46 | import System.IO (Handle) |
47 | import Control.Concurrent.MVar (newMVar) | 47 | import Control.Concurrent.MVar (newMVar) |
48 | 48 | ||
49 | import Network.Address (make6mapped4, canonize) | ||
49 | import Network.SocketLike | 50 | import Network.SocketLike |
50 | import DPut | 51 | import DPut |
51 | import DebugTag | 52 | import DebugTag |
@@ -113,24 +114,29 @@ withSession session = ServerConfig warnStderr session | |||
113 | -- thread and prevent any new sessions from starting. Currently active | 114 | -- thread and prevent any new sessions from starting. Currently active |
114 | -- session threads will not be terminated or signaled in any way. | 115 | -- session threads will not be terminated or signaled in any way. |
115 | streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle | 116 | streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle |
116 | streamServer cfg addrs = do | 117 | streamServer cfg addrs0 = do |
117 | let warn = serverWarn cfg | 118 | let warn = serverWarn cfg |
118 | family = case addrs of | 119 | family = case addrs0 of |
119 | SockAddrInet {}:_ -> AF_INET | 120 | SockAddrInet {}:_ -> AF_INET |
120 | SockAddrInet6 {}:_ -> AF_INET6 | 121 | SockAddrInet6 {}:_ -> AF_INET6 |
121 | SockAddrUnix {}:_ -> AF_UNIX | 122 | SockAddrUnix {}:_ -> AF_UNIX |
122 | [] -> AF_INET6 | 123 | [] -> AF_INET6 |
124 | addrs = map (if family == AF_INET6 then make6mapped4 else canonize) addrs0 | ||
123 | sock <- socket family Stream 0 | 125 | sock <- socket family Stream 0 |
124 | setSocketOption sock ReuseAddr 1 | 126 | setSocketOption sock ReuseAddr 1 |
125 | let tryBind addr next _ = do | 127 | let tryBind addr next = do |
128 | warn $ "Trying to bind to TCP " ++ show addr | ||
126 | tryIOError (removeSocketFile addr) | 129 | tryIOError (removeSocketFile addr) |
127 | bind sock addr | 130 | bind sock addr |
128 | `catchIOError` \e -> next (Just e) | 131 | return $ Just addr |
129 | fix $ \loop -> let again mbe = do | 132 | `catchIOError` \e -> do |
130 | forM_ mbe $ \e -> warn $ "bind-error: " <> bshow addrs <> " " <> bshow e | 133 | warn $ "bind-error: " <> bshow addr <> " " <> bshow e |
131 | threadDelay 5000000 | 134 | next |
132 | loop | 135 | bound <- fix $ \loop -> do |
133 | in foldr tryBind again addrs Nothing | 136 | m <- foldr tryBind (return Nothing) addrs |
137 | case m of | ||
138 | Just a -> return a | ||
139 | Nothing -> threadDelay 5000000 >> loop | ||
134 | listen sock maxListenQueue | 140 | listen sock maxListenQueue |
135 | thread <- mkWeakThreadId <=< forkIO $ do | 141 | thread <- mkWeakThreadId <=< forkIO $ do |
136 | bindaddr <- Socket.getSocketName sock | 142 | bindaddr <- Socket.getSocketName sock |