From 80296b10d4387200fa022e2ad5c87d23fdd11a00 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 2 Dec 2019 14:38:07 -0500 Subject: Switch to disable TCP. --- dht/OnionRouter.hs | 30 ++++++++++++++++++++++++------ dht/examples/dhtd.hs | 26 ++++++++++++++++---------- dht/examples/testTox.hs | 8 ++++---- dht/src/Network/Tox.hs | 38 ++++++++++++++++++++++++-------------- 4 files changed, 68 insertions(+), 34 deletions(-) (limited to 'dht') diff --git a/dht/OnionRouter.hs b/dht/OnionRouter.hs index bdaf04b2..e6f647b5 100644 --- a/dht/OnionRouter.hs +++ b/dht/OnionRouter.hs @@ -70,7 +70,7 @@ data OnionRouter = OnionRouter -- | A set for TCP relays to use as trampolines when UDP is not available. , trampolinesTCP :: TrampolineSet TCP.NodeInfo -- | True when we need to rely on TCP relays because UDP is apparently unavailable. - , tcpMode :: TVar Bool + , tcpMode :: TVar (Maybe Bool) -- Nothing: tcp disabled, False: use trampolinesUDP, True: use trampolinesTCP -- | The pseudo-random generator used to select onion routes. , onionDRG :: TVar ChaChaDRG -- | Building onion routes happens in a dedicated thread. See 'forkRouteBuilder'. @@ -154,11 +154,12 @@ newtype RouteEvent = BuildRoute RouteId newOnionRouter :: TransportCrypto -> (String -> IO ()) + -> Bool -- is tcp enabled? -> IO ( OnionRouter , TVar ( ChaChaDRG , Word64Map (Either (Maybe (Bool,TCP.RelayPacket) -> IO ()) (Maybe (OnionMessage Identity) -> IO ())))) -newOnionRouter crypto perror = do +newOnionRouter crypto perror tcp_enabled = do drg0 <- drgNew (rlog,pq,rm) <- atomically $ do rlog <- newTChan @@ -222,7 +223,7 @@ newOnionRouter crypto perror = do tbl (TCP.nodeSearch prober tcp) (fmap (maybe False $ const True) . TCP.tcpPing (TCP.tcpClient tcp)) - tcpmode <- newTVar True + tcpmode <- newTVar $ if tcp_enabled then Just True else Nothing let o = OnionRouter { pendingRoutes = pr , onionDRG = drg @@ -369,9 +370,12 @@ selectTrampolines or = do let tset :: (forall x. TrampolineSet x -> STM (Either [x] [x])) -> STM (Either (Either [TCP.NodeInfo] [NodeInfo]) (Either [TCP.NodeInfo] [NodeInfo])) - tset f = bool (left Right . right Right <$> f (trampolinesUDP or)) - (left Left . right Left <$> f (trampolinesTCP or)) - =<< readTVar (tcpMode or) + tset f = do + mm <- readTVar (tcpMode or) + -- TODO: better logic for deciding to use TCP or UDP trampolines. + if fromMaybe False mm + then left Left . right Left <$> f (trampolinesTCP or) + else left Right . right Right <$> f (trampolinesUDP or) atomically (tset $ internalSelectTrampolines (onionDRG or)) >>= \case Left ns -> do -- atomically $ writeTChan (routeLog or) @@ -710,3 +714,17 @@ ipClass' :: SockAddr -> IPClass ipClass' (SockAddrInet _ addr) = IPClass (fromBE32 addr .&. 0xFF000000) ipClass' (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword ipClass' _ = IPClass 0 -- unreachable. + +requestTCPMode :: OnionRouter -> Maybe Bool -> IO Bool +requestTCPMode or wanted_mode = atomically $ requestTCPModeSTM or wanted_mode + +requestTCPModeSTM :: OnionRouter -> Maybe Bool -> STM Bool +requestTCPModeSTM or wanted_mode = do + m <- readTVar (tcpMode or) + case m of + Nothing -> return False + Just oldmode -> case wanted_mode of + Just newmode -> do + writeTVar (tcpMode or) (Just newmode) + return newmode + Nothing -> return oldmode diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs index adfe0d69..9c03a4f9 100644 --- a/dht/examples/dhtd.hs +++ b/dht/examples/dhtd.hs @@ -706,7 +706,7 @@ clientSession s@Session{..} sock cnum h = do tcp_spill <- readTVar (TCP.probeSpill $ tcpProber onionRouter) tcp_cache <- readTVar (TCP.probeCache $ tcpProber onionRouter) tcp_queue <- readTVar (TCP.probeQueue $ tcpProber onionRouter) - tcpmode <- readTVar (tcpMode onionRouter) + tcpmode <- requestTCPModeSTM onionRouter Nothing tcps <- readTVar (TCP.lru $ tcpProberState onionRouter) let showRecord :: Int -> Int -> [String] showRecord n wanted_ver @@ -734,13 +734,13 @@ clientSession s@Session{..} sock cnum h = do ("onion", s) | "udp" <- strp $ map toLower s -> cmd0 $ do - atomically $ writeTVar (tcpMode onionRouter) False - hPutClient h "Onion routes: UDP." + tcpm <- requestTCPMode onionRouter (Just False) + hPutClient h $ "Onion routes: " ++ if tcpm then "TCP." else "UDP." ("onion", s) | "tcp" <- strp $ map toLower s -> cmd0 $ do - atomically $ writeTVar (tcpMode onionRouter) True - hPutClient h "Onion routes: TCP." + tcpm <- requestTCPMode onionRouter (Just True) + hPutClient h $ "Onion routes: " ++ if tcpm then "TCP." else "UDP." ("g", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do @@ -1119,6 +1119,7 @@ data Options = Options , verbosity :: Int , verboseTags :: [DebugTag] , advertiseOnAvahi :: Bool + , enableTCPDHT :: Bool } deriving (Eq,Show) @@ -1134,6 +1135,7 @@ sensibleDefaults = Options , verbosity = 2 , verboseTags = [XUnexpected, XUnused] , advertiseOnAvahi = True + , enableTCPDHT = True } data ShowHelp = ShowHelp @@ -1145,6 +1147,7 @@ usage ShowHelp ,["--dht-key ",dhtkey]],["Use ",dhtkey," as the dht key"]) , ([["-4"]] ,["Use IPv4 only"]) , ([["--noavahi"]] ,["Disable avahi advertising on LAN"]) + , ([["--notcp"]] ,["Disable TCP-relay server and client-based DHT"]) , ([["-v ",tags]] ,["Enable or disable specified DebugTags.\n DebugTags = ", listDebugTags]) ] ; dhtkey ="" ; @@ -1165,6 +1168,7 @@ parseArgs :: [String] -> Options -> Either ShowHelp Options parseArgs [] opts = Right opts parseArgs ("--help":args) opts = Left ShowHelp parseArgs ("--noavahi":args) opts = parseArgs args opts { advertiseOnAvahi = False } +parseArgs ("--notcp":args) opts = parseArgs args opts { enableTCPDHT = False } parseArgs ("--dhtkey":k:args) opts = parseArgs args opts { dhtkey = decodeSecret $ B.pack k } parseArgs ("--dht-key":k:args) opts = parseArgs args opts @@ -1384,9 +1388,9 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of Nothing -> \_ _ _ -> return () Just xmpp -> onNewToxSession xmpp ssvar invc) crypto - (\_ _ -> return ()) -- TODO: TCP relay send + (enableTCPDHT opts) -- addrTox <- getBindAddress toxport (ip6tox opts) - (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox (advertiseOnAvahi opts) + (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox (advertiseOnAvahi opts) (enableTCPDHT opts) toxSearches <- atomically $ newTVar Map.empty @@ -1592,9 +1596,11 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of dhts = Map.fromList $ ("tox4", toxDHT Tox.routing4 Want_IP4) : (if ip6tox opts - then [ ("tox6", toxDHT Tox.routing6 Want_IP6) ] + then ( ("tox6", toxDHT Tox.routing6 Want_IP6) :) + else id) + (if enableTCPDHT opts + then [ ("toxtcp", tcpDHT) ] else []) - ++ [("toxtcp", tcpDHT)] ips :: IO [SockAddr] ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox , Tox.routing6 $ Tox.toxRouting tox ] @@ -1777,7 +1783,7 @@ main = do let defaultToxData = do rster <- Tox.newContactInfo crypto <- newCrypto - (orouter,_) <- newOnionRouter crypto (dput XMisc) + (orouter,_) <- newOnionRouter crypto (dput XMisc) (enableTCPDHT opts) return (rster, orouter) (rstr,orouter) <- fromMaybe defaultToxData $ do tox <- mbtox diff --git a/dht/examples/testTox.hs b/dht/examples/testTox.hs index 57601422..6db977be 100644 --- a/dht/examples/testTox.hs +++ b/dht/examples/testTox.hs @@ -48,7 +48,7 @@ makeToxNode udp sec onSessionF = do onSessionF crypto udp - (\_ _ -> return ()) + Nothing setToxID :: Tox () -> Maybe SecretKey -> IO () @@ -113,8 +113,8 @@ main = do -- b_sessions <- sessionChan b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk - (a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False - (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False + (a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False False + (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False False threadReport False >>= putStrLn @@ -149,7 +149,7 @@ main = do -- sendMessage (toxHandshakes a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) (nodeAddr b) hs - (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False + (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False False forkIO $ do tid <- myThreadId diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs index 34e63ad8..746d8667 100644 --- a/dht/src/Network/Tox.hs +++ b/dht/src/Network/Tox.hs @@ -23,6 +23,7 @@ import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted #endif +import Control.Arrow import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad @@ -281,9 +282,10 @@ newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rende -> [String] -- ^ Bind-address to listen on. Must provide at least one. -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) -> (TransportCrypto, ContactInfo extra) - -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. + -> Bool -- Enable TCP messages. + -- ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. XXX ignored -> IO (Tox extra) -newTox keydb bindspecs onsess crypto tcp = do +newTox keydb bindspecs onsess crypto usetcp = do addrs <- mapM (`getBindAddress` True) bindspecs let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just) failedBind mbe = do @@ -294,14 +296,17 @@ newTox keydb bindspecs onsess crypto tcp = do (udp,sock) <- foldr tryBind failedBind addrs Nothing addr <- getSocketName sock dput XOnion $ "UDP bind address: " ++ show addr - (relay,sendTCP) <- tcpRelay (fst crypto) addr $ \a x -> do - let bs = S.runPut $ Onion.putRequest x - dput XOnion $ "Sending onion(0x" ++ (C8.unpack . Base16.encode) (B.take 1 bs) ++ ") from tcp-client to " ++ show a - -- mapM_ (dput XOnion) (xxd2 0 bs) - sendMessage udp (substituteLoopback addr a) bs + (relay,sendTCP) <- + if usetcp then do + fmap (Just *** Just) $ tcpRelay (fst crypto) addr $ \a x -> do + let bs = S.runPut $ Onion.putRequest x + dput XOnion $ "Sending onion(0x" ++ (C8.unpack . Base16.encode) (B.take 1 bs) ++ ") from tcp-client to " ++ show a + -- mapM_ (dput XOnion) (xxd2 0 bs) + sendMessage udp (substituteLoopback addr a) bs + else return (Nothing, Nothing) tox <- newToxOverTransport keydb addr onsess crypto udp sendTCP return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) - , toxRelayServer = Just relay + , toxRelayServer = relay } newToxCrypto :: Maybe SecretKey -> IO (TransportCrypto, ContactInfo extra) @@ -328,18 +333,18 @@ newToxOverTransport :: TVar Onion.AnnouncedKeys -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) -> (TransportCrypto, ContactInfo extra) -> Onion.UDPTransport - -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. + -> Maybe ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. -> IO (Tox extra) newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do drg <- drgNew let lookupClose _ = return Nothing mkrouting <- DHT.newRouting addr crypto updateIP updateIP - (orouter,otbl) <- newOnionRouter crypto (dput XRoutes) + (orouter,otbl) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose addr udp (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) - tcp + (fromMaybe (\_ _ -> return ()) tcp) sessions <- initSessions (sendMessage cryptonet) let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt @@ -420,14 +425,19 @@ dnssdDiscover tox ni toxid = do -- * action to bootstrap an IPv4 Kademlia table. -- -- * action to bootstrap an IPv6 Kademlia table. -forkTox :: Tox extra -> Bool -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ()) -forkTox tox with_avahi = do +forkTox :: Tox extra + -> Bool -- avahi + -> Bool -- tcp + -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ()) +forkTox tox with_avahi with_tcp = do quitHs <- forkListener "toxHandshakes" (toxHandshakes tox) quitToRoute <- forkListener "toxToRoute" (toxToRoute tox) quitOnion <- forkListener "toxOnion" (clientNet $ toxOnion tox) quitDHT <- forkListener "toxDHT" (clientNet $ toxDHT tox) quitNC <- forkListener "toxCrypto" (toxCrypto tox) - quitTCP <- forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox) + quitTCP <- if with_tcp + then forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox) + else return $ return () refresher4 <- forkPollForRefresh (DHT.refresher4 $ toxRouting tox) refresher6 <- forkPollForRefresh (DHT.refresher6 $ toxRouting tox) quitAvahi <- if with_avahi then do -- cgit v1.2.3