9 files changed, 115 insertions, 32 deletions

diff --git a/OnionRouter.hs b/OnionRouter.hs
index ad6323fe..0e0b5afb 100644
--- a/OnionRouter.hs
+++ b/OnionRouter.hs
@@ -6,10 +6,12 @@ import Control.Concurrent.Lifted.Instrument
 import Crypto.Tox
 import Network.Address
 import Network.Kademlia
-import Network.Kademlia.Routing
+import Network.Kademlia.Bootstrap
+import Network.Kademlia.Routing as R
 import Network.QueryResponse
 import Network.Tox.NodeId
 import Network.Tox.Onion.Transport
+import qualified Network.Tox.TCP as TCP
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TArray
@@ -20,11 +22,13 @@ import Data.Bits
 import Data.Bool
 import Data.List
 import qualified Data.ByteString     as B
+import Data.Hashable
 import qualified Data.HashMap.Strict as HashMap
          ;import Data.HashMap.Strict (HashMap)
 import qualified Data.IntMap         as IntMap
          ;import Data.IntMap         (IntMap)
 import Data.Maybe
+import Data.Ord
 import qualified Data.Serialize      as S
 import Data.Time.Clock.POSIX
 import Data.Typeable
@@ -75,6 +79,12 @@ data OnionRouter = OnionRouter
       -- than the 'routeVersion' set in 'routeMap' when the route should be
       -- discarded and replaced with a fresh one.
     , pendingRoutes   :: TArray Int Int
+      -- | Parameters used to implement Kademlia for TCP relays.
+    , tcpKademliaClient :: TCP.TCPClient String () Nonce8
+      -- | This thread maintains the TCP relay table.
+    , tcpKademliaThread :: ThreadId
+      -- | Kademlia table of TCP relays.
+    , tcpBucketRefresher :: BucketRefresher NodeId TCP.NodeInfo
       -- | Debug prints are written to this channel which is then flushed to
       -- 'routeLogger'.
     , routeLog        :: TChan String
@@ -138,9 +148,28 @@ gotTimeout rr = rr
 
 newtype RouteEvent = BuildRoute RouteId
 
-newOnionRouter :: (String -> IO ()) -> IO OnionRouter
-newOnionRouter perror = do
+newOnionRouter :: TransportCrypto -> (String -> IO ()) -> IO OnionRouter
+newOnionRouter crypto perror = do
     drg0 <- drgNew
+    (tbl,tcp) <- do
+        client <- TCP.newClient crypto
+        let addr = SockAddrInet 0 0
+            tentative_udp = NodeInfo
+                { nodeId   = key2id $ transportPublic crypto
+                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
+                , nodePort = fromMaybe 0 $ sockAddrPort addr
+                }
+            tentative_info = TCP.NodeInfo tentative_udp (fromIntegral 443)
+        tbl <- atomically $ newTVar
+                          $ R.nullTable (comparing TCP.nodeId)
+                                        (\s -> hashWithSalt s . TCP.nodeId)
+                                        tentative_info
+                                        R.defaultBucketCount
+        return $ (,) tbl TCP.TCPClient
+            { tcpCrypto     = crypto
+            , tcpClient     = client
+            , tcpGetGateway = selectGateway tbl
+            }
     or <- atomically $ do
         -- chan <- newTChan
         drg <- newTVar drg0
@@ -152,6 +181,7 @@ newOnionRouter perror = do
         tc <- newTVar 0
         pr <- newArray (0,11) 0
         rlog <- newTChan
+        refresher <- newBucketRefresher tbl (TCP.nodeSearch tcp) (fmap (maybe False $ const True) . TCP.tcpPing (TCP.tcpClient tcp))
         return OnionRouter
             { pendingRoutes = pr
             , onionDRG = drg
@@ -160,14 +190,23 @@ newOnionRouter perror = do
             , trampolineNodes = tn
             , trampolineIds = ti
             , trampolineCount = tc
+            , tcpKademliaClient = tcp
+            , tcpBucketRefresher = refresher
             , routeLog = rlog
-            , routeThread = error "Failed to invoke forkRouteBuilder"
+            , routeThread = error "forkRouteBuilder not invoked (missing onion route builder thread)."
+            , tcpKademliaThread = error "forkRouteBuilder not invoked (missing TCP bucket maintenance thread)."
             , routeLogger = perror
             }
     return or
 
+selectGateway :: TVar (R.BucketList TCP.NodeInfo) -> NodeInfo -> STM (Maybe TCP.NodeInfo)
+selectGateway tbl ni = do
+    ns <- kclosest TCP.tcpSpace 2 (nodeId ni) <$> readTVar tbl
+    return $ listToMaybe $ dropWhile (\n -> TCP.nodeId n == nodeId ni) ns
+
 forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> IO OnionRouter
 forkRouteBuilder or getnodes = do
+    bktsThread <- forkPollForRefresh $ tcpBucketRefresher or
     tid <- forkIO $ do
         me <- myThreadId
         labelThread me "OnionRouter"
@@ -186,7 +225,8 @@ forkRouteBuilder or getnodes = do
                         in do event <- foldr1 orElse stms
                               return $ handleEvent getnodes or { routeThread = me } event)
             io
-    return or { routeThread = tid }
+    return or { routeThread       = tid
+              , tcpKademliaThread = bktsThread }
 
 generateNodeId :: MonadRandom m => m NodeId
 generateNodeId = either (error "unable to make random nodeid")
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index f8a18388..8cdd1cdc 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -745,7 +745,7 @@ deliverMessage state fail msg =
             deliverToConsole state fail msg'
         else do
             forM_ chans $ \(from',Conn { connChan=chan}) -> do
-            -- TODO: Cloning isn't really neccessary unless there are multiple
+            -- TODO: Cloning isn't really necessary unless there are multiple
             -- destinations and we should probably transition to minimal cloning,
             -- or else we should distinguish between announcable stanzas and
             -- consumable stanzas and announcables use write-only broadcast
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 04b8c064..959383dc 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -73,6 +73,7 @@ import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.QueryResponse
 import Network.StreamServer
+import Network.Kademlia.Bootstrap (refreshBuckets,bootstrap)
 import Network.Kademlia.CommonAPI
 import Network.Kademlia.Persistence
 import Network.Kademlia.Routing as R
@@ -95,6 +96,7 @@ import qualified Network.Tox.DHT.Handlers as Tox
 import qualified Network.Tox.Onion.Transport as Tox
 import qualified Network.Tox.Onion.Handlers as Tox
 import qualified Network.Tox.Crypto.Transport as Tox
+import qualified Network.Tox.TCP as TCP
 import Data.Typeable
 import Network.Tox.ContactInfo as Tox
 import OnionRouter
@@ -1316,6 +1318,8 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
 
             toxSearches <- atomically $ newTVar Map.empty
 
+            tcpSearches <- atomically $ newTVar Map.empty
+
             let toxDHT bkts wantip = DHT
                     { dhtBuckets = bkts (Tox.toxRouting tox)
                     , dhtPing    = Map.fromList
@@ -1486,11 +1490,36 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
                                         Want_IP4 -> toxStrap4
                                         Want_IP6 -> toxStrap6
                     }
+                tcpclient = tcpKademliaClient $ Tox.toxOnionRoutes tox
+                tcpRefresher = tcpBucketRefresher $ Tox.toxOnionRoutes tox
+                tcpDHT = DHT
+                    { dhtBuckets = refreshBuckets tcpRefresher
+                    , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
+                    , dhtPing = Map.singleton "ping" DHTPing
+                                    { pingQuery = noArgPing $ TCP.tcpPing (TCP.tcpClient tcpclient)
+                                    , pingShowResult = show
+                                    }
+                    , dhtQuery = Map.singleton "node" DHTQuery
+                                    { qsearch = TCP.nodeSearch tcpclient
+                                    , qhandler = \ni nid -> do
+                                        ns <- R.kclosest (searchSpace $ TCP.nodeSearch tcpclient) searchK nid
+                                                <$> atomically (readTVar $ refreshBuckets tcpRefresher)
+                                        return (ns,ns,Just ())
+                                    , qshowR = show -- TCP.NodeInfo
+                                    , qshowTok = (const Nothing)
+                                    }
+                    , dhtAnnouncables = Map.empty
+                    , dhtParseId = readEither :: String -> Either String Tox.NodeId
+                    , dhtSearches = tcpSearches
+                    , dhtFallbackNodes = return []
+                    , dhtBootstrap = bootstrap tcpRefresher
+                    }
                 dhts = Map.fromList $
                         ("tox4", toxDHT Tox.routing4 Want_IP4)
                         : if ip6tox opts
                             then [ ("tox6", toxDHT Tox.routing6 Want_IP6) ]
                             else []
+                        ++ [("toxtcp", tcpDHT)]
                 ips :: IO [SockAddr]
                 ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
                                                  , Tox.routing6 $ Tox.toxRouting tox ]
@@ -1668,7 +1697,8 @@ main = do
         installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
         let defaultToxData = do
                 rster <- Tox.newContactInfo
-                orouter <- newOnionRouter (dput XMisc)
+                crypto <- newCrypto
+                orouter <- newOnionRouter crypto (dput XMisc)
                 return (rster, orouter)
         (rstr,orouter) <- fromMaybe defaultToxData $ do
             tox <- mbtox
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index 573efcba..a29657af 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -563,11 +563,11 @@ newClient swarms addr = do
         -- have a client to send queries with.
         let nullPing = const $ return False
             nullSearch = mainlineSearch $ \_ _ -> return Nothing
-        refresher4 <- newBucketRefresher tentative_info nullSearch nullPing
-        refresher6 <- newBucketRefresher tentative_info6 nullSearch nullPing
-        let tbl4 = refreshBuckets refresher4
-            tbl6 = refreshBuckets refresher6
-            updateIPVote tblvar addrvar a = do
+        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount
+        refresher4 <- newBucketRefresher tbl4 nullSearch nullPing
+        tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount
+        refresher6 <- newBucketRefresher tbl6 nullSearch nullPing
+        let updateIPVote tblvar addrvar a = do
                 bkts <- readTVar tblvar
                 case bep42 a (nodeId $ R.thisNode bkts) of
                     Just nid -> do
diff --git a/src/Network/Kademlia.hs b/src/Network/Kademlia.hs
index 44ef2ec1..488a53ac 100644
--- a/src/Network/Kademlia.hs
+++ b/src/Network/Kademlia.hs
@@ -66,7 +66,7 @@ contramapIR f ir = InsertionReporter
     , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b
     }
 
--- | All the IO operations neccessary to maintain a Kademlia routing table.
+-- | All the IO operations necessary to maintain a Kademlia routing table.
 data TableStateIO ni = TableStateIO
     { -- | Write the routing table.  Typically 'writeTVar'.
       tblWrite :: R.BucketList ni -> STM ()
@@ -99,7 +99,7 @@ vanillaIO var ping = TableStateIO
     , tblTransition = const $ return $ return ()
     }
 
--- | Everything neccessary to maintain a routing table of /ni/ (node
+-- | Everything necessary to maintain a routing table of /ni/ (node
 -- information) entries.
 data Kademlia nid ni = Kademlia (InsertionReporter ni)
                                 (KademliaSpace nid ni)
@@ -109,7 +109,7 @@ data Kademlia nid ni = Kademlia (InsertionReporter ni)
 -- Helper to 'insertNode'.
 --
 -- Adapt return value from 'updateForPingResult' into a
--- more easily groked list of transitions.
+-- more easily grokked list of transitions.
 transition :: (ni,Maybe (t,ni)) -> [RoutingTransition ni]
 transition (x,m) =
     -- Just _  <- m  =  Node transition:  Accepted  --> Stranger
diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
index aad8a81e..0f5d4e4d 100644
--- a/src/Network/Kademlia/Bootstrap.hs
+++ b/src/Network/Kademlia/Bootstrap.hs
@@ -77,14 +77,14 @@ data BucketRefresher nid ni = forall tok addr. Ord addr =>  BucketRefresher
 
 newBucketRefresher :: ( Ord addr, Hashable addr
                       , SensibleNodeId nid ni )
-                    => ni
+                    => TVar (R.BucketList ni)
                     -> Search nid addr tok ni ni
                     -> (ni -> IO Bool)
                     -> STM (BucketRefresher nid ni)
-newBucketRefresher template_ni sch ping = do
+newBucketRefresher bkts sch ping = do
     let spc    = searchSpace sch
         nodeId = kademliaLocation spc
-    bkts <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) template_ni R.defaultBucketCount
+    -- bkts <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) template_ni R.defaultBucketCount
     sched <- newTVar Int.empty
     lasttouch <- newTVar 0 -- Would use getPOSIXTime here, or minBound, but alas...
     bootstrapVar <- newTVar True -- Start in bootstrapping mode.
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index b98252d3..1e82c0c4 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -285,15 +285,16 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
     let lookupClose _ = return Nothing
 
     mkrouting <- DHT.newRouting addr crypto updateIP updateIP
-    orouter <- newOnionRouter $ dput XRoutes
+    orouter <- newOnionRouter crypto $ dput XRoutes
     (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp tcp
     sessions <- initSessions (sendMessage cryptonet)
 
     let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
         tbl4 = DHT.routing4 $ mkrouting (error "missing client")
         tbl6 = DHT.routing6 $ mkrouting (error "missing client")
+        updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter tr
     dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
-                    $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net
+                    $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net
 
     hscache <- newHandshakeCache crypto (sendMessage handshakes)
     let sparams = SessionParams
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index 2062b51d..2fbac5d3 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -18,7 +18,8 @@ import Network.Address               (WantIP (..), ipFamily, fromSockAddr, sockA
 import qualified Network.Kademlia.Routing as R
 import Control.TriadCommittee
 import System.Global6
-import OnionRouter
+import DPut
+import DebugTag
 
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Char8 as C8
@@ -27,6 +28,8 @@ import Control.Arrow
 import Control.Monad
 import Control.Concurrent.Lifted.Instrument
 import Control.Concurrent.STM
+import Data.Hashable
+import Data.Ord
 import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
 import Network.Socket
 import qualified Data.HashMap.Strict as HashMap
@@ -39,8 +42,6 @@ import Data.IP
 import Data.Maybe
 import Data.Serialize (Serialize)
 import Data.Word
-import DPut
-import DebugTag
 
 data TransactionId = TransactionId
  { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
@@ -195,10 +196,10 @@ newRouting addr crypto update4 update6 = do
                 , searchNodeAddress = nodeIP &&& nodePort
                 , searchQuery       = \_ _ -> return Nothing
                 }
-        refresher4 <- newBucketRefresher tentative_info4 nullSearch nullPing
-        refresher6 <- newBucketRefresher tentative_info6 nullSearch nullPing
-        let tbl4 = refreshBuckets refresher4
-            tbl6 = refreshBuckets refresher6
+        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount
+        tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount
+        refresher4 <- newBucketRefresher tbl4 nullSearch nullPing
+        refresher6 <- newBucketRefresher tbl6 nullSearch nullPing
         committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4
         committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
         cbvar <- newTVar HashMap.empty
@@ -412,7 +413,11 @@ getNodes client cbvar nid addr = do
                         rumoredAddress cb now (nodeAddr addr) n
     return $ fmap unwrapNodes $ join reply
 
-updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO ()
+updateRouting :: Client -> Routing
+                        -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
+                        -> NodeInfo
+                        -> Message
+                        -> IO ()
 updateRouting client routing orouter naddr msg
     | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery
                                        -- Ignore lan announcements until they reply to our ping.
@@ -431,7 +436,11 @@ updateRouting client routing orouter naddr msg
         Want_Both -> do dput XMisc "BUG:unreachable"
                         error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
 
-updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO ()
+updateTable :: Client -> NodeInfo
+                      -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
+                      -> TriadCommittee NodeId SockAddr
+                      -> BucketRefresher NodeId NodeInfo
+                      -> IO ()
 updateTable client naddr orouter committee refresher = do
         self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
         -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr)
@@ -439,7 +448,9 @@ updateTable client naddr orouter committee refresher = do
             -- TODO: IP address vote?
             insertNode (toxKademlia client committee orouter refresher) naddr
 
-toxKademlia :: Client -> TriadCommittee NodeId SockAddr -> OnionRouter
+toxKademlia :: Client
+                -> TriadCommittee NodeId SockAddr
+                -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
                 -> BucketRefresher NodeId NodeInfo
                 -> Kademlia NodeId NodeInfo
 toxKademlia client committee orouter refresher
@@ -449,7 +460,8 @@ toxKademlia client committee orouter refresher
                    { tblTransition = \tr -> do
                         io1 <- transitionCommittee committee tr
                         io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
-                        hookBucketList toxSpace (refreshBuckets refresher) orouter tr
+                        -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr
+                        orouter (refreshBuckets refresher) tr
                         return $ do
                             io1 >> io2
                             {-
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
index 98be1e3a..1c68249e 100644
--- a/src/Network/Tox/NodeId.hs
+++ b/src/Network/Tox/NodeId.hs
@@ -320,7 +320,7 @@ instance Read NodeInfo where
     RP.skipSpaces
     let n = 43 -- characters in node id.
         parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
-                      RP.+++ RP.munch (not . isSpace)
+                      RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char])))
         nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy b64digit)
                       RP.char '@' RP.+++ RP.satisfy isSpace
                       addrstr <- parseAddr