Integrated cli interface to TCP Kademlia table.

6 files changed, 38 insertions, 25 deletions

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