Switch to disable TCP.

4 files changed, 68 insertions, 34 deletions

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 ="<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