diff options
Diffstat (limited to 'src/Network/Tox/DHT')
-rw-r--r-- | src/Network/Tox/DHT/Handlers.hs | 34 |
1 files changed, 23 insertions, 11 deletions
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 | |||
18 | import qualified Network.Kademlia.Routing as R | 18 | import qualified Network.Kademlia.Routing as R |
19 | import Control.TriadCommittee | 19 | import Control.TriadCommittee |
20 | import System.Global6 | 20 | import System.Global6 |
21 | import OnionRouter | 21 | import DPut |
22 | import DebugTag | ||
22 | 23 | ||
23 | import qualified Data.ByteArray as BA | 24 | import qualified Data.ByteArray as BA |
24 | import qualified Data.ByteString.Char8 as C8 | 25 | import qualified Data.ByteString.Char8 as C8 |
@@ -27,6 +28,8 @@ import Control.Arrow | |||
27 | import Control.Monad | 28 | import Control.Monad |
28 | import Control.Concurrent.Lifted.Instrument | 29 | import Control.Concurrent.Lifted.Instrument |
29 | import Control.Concurrent.STM | 30 | import Control.Concurrent.STM |
31 | import Data.Hashable | ||
32 | import Data.Ord | ||
30 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | 33 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) |
31 | import Network.Socket | 34 | import Network.Socket |
32 | import qualified Data.HashMap.Strict as HashMap | 35 | import qualified Data.HashMap.Strict as HashMap |
@@ -39,8 +42,6 @@ import Data.IP | |||
39 | import Data.Maybe | 42 | import Data.Maybe |
40 | import Data.Serialize (Serialize) | 43 | import Data.Serialize (Serialize) |
41 | import Data.Word | 44 | import Data.Word |
42 | import DPut | ||
43 | import DebugTag | ||
44 | 45 | ||
45 | data TransactionId = TransactionId | 46 | data TransactionId = TransactionId |
46 | { transactionKey :: Nonce8 -- ^ Used to lookup pending query. | 47 | { transactionKey :: Nonce8 -- ^ Used to lookup pending query. |
@@ -195,10 +196,10 @@ newRouting addr crypto update4 update6 = do | |||
195 | , searchNodeAddress = nodeIP &&& nodePort | 196 | , searchNodeAddress = nodeIP &&& nodePort |
196 | , searchQuery = \_ _ -> return Nothing | 197 | , searchQuery = \_ _ -> return Nothing |
197 | } | 198 | } |
198 | refresher4 <- newBucketRefresher tentative_info4 nullSearch nullPing | 199 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount |
199 | refresher6 <- newBucketRefresher tentative_info6 nullSearch nullPing | 200 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount |
200 | let tbl4 = refreshBuckets refresher4 | 201 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing |
201 | tbl6 = refreshBuckets refresher6 | 202 | refresher6 <- newBucketRefresher tbl6 nullSearch nullPing |
202 | committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4 | 203 | committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4 |
203 | committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6 | 204 | committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6 |
204 | cbvar <- newTVar HashMap.empty | 205 | cbvar <- newTVar HashMap.empty |
@@ -412,7 +413,11 @@ getNodes client cbvar nid addr = do | |||
412 | rumoredAddress cb now (nodeAddr addr) n | 413 | rumoredAddress cb now (nodeAddr addr) n |
413 | return $ fmap unwrapNodes $ join reply | 414 | return $ fmap unwrapNodes $ join reply |
414 | 415 | ||
415 | updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO () | 416 | updateRouting :: Client -> Routing |
417 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
418 | -> NodeInfo | ||
419 | -> Message | ||
420 | -> IO () | ||
416 | updateRouting client routing orouter naddr msg | 421 | updateRouting client routing orouter naddr msg |
417 | | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery | 422 | | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery |
418 | -- Ignore lan announcements until they reply to our ping. | 423 | -- Ignore lan announcements until they reply to our ping. |
@@ -431,7 +436,11 @@ updateRouting client routing orouter naddr msg | |||
431 | Want_Both -> do dput XMisc "BUG:unreachable" | 436 | Want_Both -> do dput XMisc "BUG:unreachable" |
432 | error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ | 437 | error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ |
433 | 438 | ||
434 | updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO () | 439 | updateTable :: Client -> NodeInfo |
440 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
441 | -> TriadCommittee NodeId SockAddr | ||
442 | -> BucketRefresher NodeId NodeInfo | ||
443 | -> IO () | ||
435 | updateTable client naddr orouter committee refresher = do | 444 | updateTable client naddr orouter committee refresher = do |
436 | self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) | 445 | self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) |
437 | -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr) | 446 | -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr) |
@@ -439,7 +448,9 @@ updateTable client naddr orouter committee refresher = do | |||
439 | -- TODO: IP address vote? | 448 | -- TODO: IP address vote? |
440 | insertNode (toxKademlia client committee orouter refresher) naddr | 449 | insertNode (toxKademlia client committee orouter refresher) naddr |
441 | 450 | ||
442 | toxKademlia :: Client -> TriadCommittee NodeId SockAddr -> OnionRouter | 451 | toxKademlia :: Client |
452 | -> TriadCommittee NodeId SockAddr | ||
453 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
443 | -> BucketRefresher NodeId NodeInfo | 454 | -> BucketRefresher NodeId NodeInfo |
444 | -> Kademlia NodeId NodeInfo | 455 | -> Kademlia NodeId NodeInfo |
445 | toxKademlia client committee orouter refresher | 456 | toxKademlia client committee orouter refresher |
@@ -449,7 +460,8 @@ toxKademlia client committee orouter refresher | |||
449 | { tblTransition = \tr -> do | 460 | { tblTransition = \tr -> do |
450 | io1 <- transitionCommittee committee tr | 461 | io1 <- transitionCommittee committee tr |
451 | io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr | 462 | io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr |
452 | hookBucketList toxSpace (refreshBuckets refresher) orouter tr | 463 | -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr |
464 | orouter (refreshBuckets refresher) tr | ||
453 | return $ do | 465 | return $ do |
454 | io1 >> io2 | 466 | io1 >> io2 |
455 | {- | 467 | {- |