Switch to disable TCP.

1 files changed, 24 insertions, 14 deletions

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