diff options
-rw-r--r-- | dht/Announcer.hs | 5 | ||||
-rw-r--r-- | dht/Announcer/Tox.hs | 2 | ||||
-rw-r--r-- | dht/ToxManager.hs | 52 |
3 files changed, 41 insertions, 18 deletions
diff --git a/dht/Announcer.hs b/dht/Announcer.hs index e7c0bcd2..bdbf5ecc 100644 --- a/dht/Announcer.hs +++ b/dht/Announcer.hs | |||
@@ -176,7 +176,10 @@ listener announcer = relisten | |||
176 | Just cmd -> return $ handleCommand cmd | 176 | Just cmd -> return $ handleCommand cmd |
177 | Nothing -> do | 177 | Nothing -> do |
178 | writeTVar (scheduled announcer) (Schedule queue') | 178 | writeTVar (scheduled announcer) (Schedule queue') |
179 | (fmap (>> relisten) (fmap fork (f announcer k now))) | 179 | io <- f announcer k now |
180 | return $ do | ||
181 | forkLabeled ("announcer:item:"++unpackAnnounceKey announcer k) io | ||
182 | relisten | ||
180 | where | 183 | where |
181 | modifyScheduled f = modifyTVar (scheduled announcer) (Schedule . f . unSchedule) | 184 | modifyScheduled f = modifyTVar (scheduled announcer) (Schedule . f . unSchedule) |
182 | declareInactive = writeTVar (announcerActive announcer) False | 185 | declareInactive = writeTVar (announcerActive announcer) False |
diff --git a/dht/Announcer/Tox.hs b/dht/Announcer/Tox.hs index 00eb219b..38e5bbfa 100644 --- a/dht/Announcer/Tox.hs +++ b/dht/Announcer/Tox.hs | |||
@@ -193,7 +193,7 @@ scheduleSearch announcer k SearchMethod{sSearch,sWithResult,sNearestNodes,sTarge | |||
193 | mutex <- newMVar () -- This mutex insures one search at a time. | 193 | mutex <- newMVar () -- This mutex insures one search at a time. |
194 | let astate = AnnounceState st ns | 194 | let astate = AnnounceState st ns |
195 | onResult sr = do | 195 | onResult sr = do |
196 | runAction announcer "with-search-result" $ do | 196 | runAction announcer ("search-result:"++unpackAnnounceKey announcer k) $ do |
197 | got <- sWithResult r sr | 197 | got <- sWithResult r sr |
198 | -- If we had a way to get the source of a search result, we might want to | 198 | -- If we had a way to get the source of a search result, we might want to |
199 | -- treat it similarly to an announcing node and remember it in the 'aStoringNodes' | 199 | -- treat it similarly to an announcing node and remember it in the 'aStoringNodes' |
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs index 7d164b9d..4d8910e2 100644 --- a/dht/ToxManager.hs +++ b/dht/ToxManager.hs | |||
@@ -67,6 +67,7 @@ import GHC.Conc (labelThread) | |||
67 | import Connection | 67 | import Connection |
68 | import Connection.Tcp (TCPStatus) | 68 | import Connection.Tcp (TCPStatus) |
69 | import GHC.Conc (unsafeIOToSTM) | 69 | import GHC.Conc (unsafeIOToSTM) |
70 | import System.IO.Error | ||
70 | 71 | ||
71 | data Pending = ToxStatus ToxProgress | XMPPStatus TCPStatus | 72 | data Pending = ToxStatus ToxProgress | XMPPStatus TCPStatus |
72 | 73 | ||
@@ -288,31 +289,41 @@ connectViaRelay tx theirKey theirDhtKey ann tkey now = do | |||
288 | Nothing -> return $ return () | 289 | Nothing -> return $ return () |
289 | Just contact -> do | 290 | Just contact -> do |
290 | established <- activeSesh tx theirKey | 291 | established <- activeSesh tx theirKey |
292 | runAction ann "connectViaRelay-print" $ do | ||
293 | dput XMan $ "connectViaRelay("++unpackAnnounceKey ann tkey++") " ++ show established | ||
291 | return $ when (not established) go | 294 | return $ when (not established) go |
295 | -- $ scheduleImmediately ann tkey $ ScheduledItem go | ||
296 | -- return $ return () | ||
292 | where | 297 | where |
293 | myPublicKey = toPublic $ userSecret (txAccount tx) | 298 | myPublicKey = toPublic $ userSecret (txAccount tx) |
294 | me = key2id myPublicKey | 299 | me = key2id myPublicKey |
295 | tkey = akeyConnectTCP (txAnnouncer tx) me theirKey | 300 | tkey = akeyConnectTCP (txAnnouncer tx) me theirKey |
296 | go = do | 301 | go = do |
297 | let Tox.SendNodes ns = Tox.dhtpkNodes theirDhtKey | 302 | let Tox.SendNodes ns = Tox.dhtpkNodes theirDhtKey |
298 | mcons <- forM ns $ \ni -> do | 303 | mcons <- forM (filter (\n -> TCP.tcpPort n /= 0) ns) $ \ni -> do |
299 | mcon <- Multi.tcpConnectionRequest (txTCP tx) (Tox.dhtpk theirDhtKey) ni | 304 | mcon <- Multi.tcpConnectionRequest (txTCP tx) (Tox.dhtpk theirDhtKey) ni |
300 | return mcon | 305 | return mcon |
301 | let oobs = [ Multi.TCP ==> TCP.ViaRelay Nothing (Tox.key2id $ Tox.dhtpk theirDhtKey) ni | ni <- ns ] | 306 | let oobs = [ Multi.TCP ==> TCP.ViaRelay Nothing (Tox.key2id $ Tox.dhtpk theirDhtKey) ni | ni <- ns ] |
302 | forM_ (catMaybes mcons ++ oobs) $ \ni -> do | 307 | addrs = catMaybes mcons ++ oobs |
303 | cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case | 308 | -- wait a sec to give connection requests a chance to be processed. |
304 | Nothing -> return () | 309 | -- probably we should be handling ConnectNotification/DisconnectNotification |
305 | Just cookie -> do | 310 | (\kont -> atomically $ scheduleRel ann tkey (ScheduledItem $ \_ _ _ -> return kont) 1) $ do |
306 | cookieCreationStamp <- getPOSIXTime | 311 | dput XMan $ "connectViaRelay: address count is " ++ show (length addrs) |
307 | let their_nid = key2id $ dhtpk theirDhtKey | 312 | forM_ addrs $ \ni -> do |
308 | dput XMan $ show their_nid ++ " --> cookie (TCP)" | 313 | cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case |
309 | hs <- cacheHandshake (toxHandshakeCache $ txTox tx) (userSecret (txAccount tx)) theirKey ni cookie | 314 | Nothing -> dput XMan $ "connectViaRelay: no cookie from " ++ show ni |
310 | dput XMan $ show their_nid ++ "<-- handshake " ++ show (key2id theirKey) ++ " (TCP)" | 315 | Just cookie -> do |
311 | sendMessage (toxHandshakes $ txTox tx) (Multi.sessionAddr ni) hs | 316 | cookieCreationStamp <- getPOSIXTime |
312 | atomically $ do | 317 | let their_nid = key2id $ dhtpk theirDhtKey |
313 | -- Try again in 5 seconds. | 318 | dput XMan $ show their_nid ++ " --> cookie (TCP)" |
314 | let theirDhtKey' = theirDhtKey' { Tox.dhtpkNodes = Tox.SendNodes (cycled ns) } | 319 | hs <- cacheHandshake (toxHandshakeCache $ txTox tx) (userSecret (txAccount tx)) theirKey ni cookie |
315 | scheduleRel ann tkey (ScheduledItem $ connectViaRelay tx theirKey theirDhtKey') 5 | 320 | dput XMan $ show their_nid ++ "<-- handshake " ++ show (key2id theirKey) ++ " (TCP)" |
321 | sendMessage (toxHandshakes $ txTox tx) (Multi.sessionAddr ni) hs | ||
322 | dput XMan $ "connectViaRelay trying again in 5 seconds ... " | ||
323 | atomically $ do | ||
324 | -- Try again in 5 seconds. | ||
325 | let theirDhtKey' = theirDhtKey { Tox.dhtpkNodes = Tox.SendNodes (cycled ns) } | ||
326 | scheduleRel ann tkey (ScheduledItem $ connectViaRelay tx theirKey theirDhtKey') 5 | ||
316 | 327 | ||
317 | gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () | 328 | gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () |
318 | gotDhtPubkey theirDhtKey tx theirKey = do | 329 | gotDhtPubkey theirDhtKey tx theirKey = do |
@@ -368,7 +379,11 @@ gotDhtPubkey theirDhtKey tx theirKey = do | |||
368 | assume :: Show infosource => AnnounceKey -> POSIXTime -> infosource -> NodeInfo -> STM () | 379 | assume :: Show infosource => AnnounceKey -> POSIXTime -> infosource -> NodeInfo -> STM () |
369 | assume akey time addr ni = do | 380 | assume akey time addr ni = do |
370 | runAction (txAnnouncer tx) "rumor" $ do | 381 | runAction (txAnnouncer tx) "rumor" $ do |
371 | dput XMan $ show ("rumor", showak akey, time, addr, ni) | 382 | dput XMan $ unlines |
383 | [ "Rumor " ++ showak akey | ||
384 | , " " ++ show addr | ||
385 | , " according to " ++ show ni | ||
386 | ] | ||
372 | 387 | ||
373 | observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () | 388 | observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () |
374 | observe akey time ni@(nodeAddr -> addr) = do | 389 | observe akey time ni@(nodeAddr -> addr) = do |
@@ -642,6 +657,11 @@ startConnecting0 tx them contact reason = do | |||
642 | ++ take 8 (show $ key2id $ Tox.dhtpk dkey) | 657 | ++ take 8 (show $ key2id $ Tox.dhtpk dkey) |
643 | ] | 658 | ] |
644 | sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey) | 659 | sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey) |
660 | `catchIOError` \e -> do | ||
661 | dput XMan $ unlines | ||
662 | [ "Error sharing DHTKey to " ++ show route | ||
663 | , " " ++ show e | ||
664 | ] | ||
645 | forM_ soliciting $ \cksum@(NoSpam nospam _)-> do | 665 | forM_ soliciting $ \cksum@(NoSpam nospam _)-> do |
646 | dput XMan $ unwords [ take 8 (show $ key2id theirkey) | 666 | dput XMan $ unwords [ take 8 (show $ key2id theirkey) |
647 | , show (nodeAddr $ Tox.rendezvousNode rendezvous) | 667 | , show (nodeAddr $ Tox.rendezvousNode rendezvous) |