WIP: efforts regarding tcp-mediated connections.

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
               Just cmd -> return $ handleCommand cmd
               Nothing  -> do
                 writeTVar (scheduled announcer) (Schedule queue')
-                (fmap (>> relisten) (fmap fork (f announcer k now)))
+                io <- f announcer k now
+                return $ do
+                    forkLabeled ("announcer:item:"++unpackAnnounceKey announcer k) io
+                    relisten
       where
         modifyScheduled f               = modifyTVar (scheduled announcer) (Schedule . f . unSchedule)
         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
     mutex <- newMVar () -- This mutex insures one search at a time.
     let astate = AnnounceState st ns
         onResult sr = do
-                runAction announcer "with-search-result" $ do
+                runAction announcer ("search-result:"++unpackAnnounceKey announcer k) $ do
                     got <- sWithResult r sr
                     -- If we had a way to get the source of a search result, we might want to
                     -- 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)
 import Connection
 import Connection.Tcp (TCPStatus)
 import GHC.Conc       (unsafeIOToSTM)
+import System.IO.Error
 
 data Pending = ToxStatus ToxProgress | XMPPStatus TCPStatus
 
@@ -288,31 +289,41 @@ connectViaRelay tx theirKey theirDhtKey ann tkey now = do
         Nothing -> return $ return ()
         Just contact -> do
             established <- activeSesh tx theirKey
+            runAction ann "connectViaRelay-print" $ do
+                dput XMan $ "connectViaRelay("++unpackAnnounceKey ann tkey++") " ++ show established
             return $ when (not established) go
+            -- $ scheduleImmediately ann tkey $ ScheduledItem go
+            -- return $ return ()
  where
     myPublicKey = toPublic $ userSecret (txAccount tx)
     me = key2id myPublicKey
     tkey = akeyConnectTCP (txAnnouncer tx) me theirKey
     go = do
         let Tox.SendNodes ns = Tox.dhtpkNodes theirDhtKey
-        mcons <- forM ns $ \ni -> do
+        mcons <- forM (filter (\n -> TCP.tcpPort n /= 0) ns) $ \ni -> do
             mcon <- Multi.tcpConnectionRequest (txTCP tx) (Tox.dhtpk theirDhtKey) ni
             return mcon
         let oobs = [ Multi.TCP ==> TCP.ViaRelay Nothing (Tox.key2id $ Tox.dhtpk theirDhtKey) ni | ni <- ns ]
-        forM_ (catMaybes mcons ++ oobs) $ \ni -> do
-          cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case
-            Nothing -> return ()
-            Just cookie -> do
-                cookieCreationStamp <- getPOSIXTime
-                let their_nid = key2id $ dhtpk theirDhtKey
-                dput XMan $ show their_nid ++ " --> cookie (TCP)"
-                hs <- cacheHandshake (toxHandshakeCache $ txTox tx) (userSecret (txAccount tx)) theirKey ni cookie
-                dput XMan $  show their_nid ++ "<-- handshake " ++ show (key2id theirKey) ++ " (TCP)"
-                sendMessage (toxHandshakes $ txTox tx) (Multi.sessionAddr ni) hs
-        atomically $ do
-            -- Try again in 5 seconds.
-            let theirDhtKey' = theirDhtKey' { Tox.dhtpkNodes = Tox.SendNodes (cycled ns) }
-            scheduleRel ann tkey (ScheduledItem $ connectViaRelay tx theirKey theirDhtKey') 5
+            addrs = catMaybes mcons ++ oobs
+        -- wait a sec to give connection requests a chance to be processed.
+        -- probably we should be handling ConnectNotification/DisconnectNotification
+        (\kont -> atomically $ scheduleRel ann tkey (ScheduledItem $ \_ _ _ -> return kont) 1) $ do
+            dput XMan $ "connectViaRelay: address count is " ++ show (length addrs)
+            forM_ addrs $ \ni -> do
+              cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case
+                Nothing -> dput XMan $ "connectViaRelay: no cookie from " ++ show ni
+                Just cookie -> do
+                    cookieCreationStamp <- getPOSIXTime
+                    let their_nid = key2id $ dhtpk theirDhtKey
+                    dput XMan $ show their_nid ++ " --> cookie (TCP)"
+                    hs <- cacheHandshake (toxHandshakeCache $ txTox tx) (userSecret (txAccount tx)) theirKey ni cookie
+                    dput XMan $  show their_nid ++ "<-- handshake " ++ show (key2id theirKey) ++ " (TCP)"
+                    sendMessage (toxHandshakes $ txTox tx) (Multi.sessionAddr ni) hs
+            dput XMan $ "connectViaRelay trying again in 5 seconds ... "
+            atomically $ do
+                -- Try again in 5 seconds.
+                let theirDhtKey' = theirDhtKey { Tox.dhtpkNodes = Tox.SendNodes (cycled ns) }
+                scheduleRel ann tkey (ScheduledItem $ connectViaRelay tx theirKey theirDhtKey') 5
 
 gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
 gotDhtPubkey theirDhtKey tx theirKey = do
@@ -368,7 +379,11 @@ gotDhtPubkey theirDhtKey tx theirKey = do
     assume :: Show infosource => AnnounceKey -> POSIXTime -> infosource -> NodeInfo -> STM ()
     assume akey time addr ni = do
       runAction (txAnnouncer tx) "rumor" $ do
-          dput XMan $ show ("rumor", showak akey, time, addr, ni)
+          dput XMan $ unlines
+            [ "Rumor " ++ showak akey
+            , "  " ++ show addr
+            , "  according to " ++ show ni
+            ]
 
     observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM ()
     observe akey time ni@(nodeAddr -> addr) = do
@@ -642,6 +657,11 @@ startConnecting0 tx them contact reason = do
                                           ++ take 8 (show $ key2id $ Tox.dhtpk dkey)
                                         ]
                     sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey)
+                        `catchIOError` \e -> do
+                            dput XMan $ unlines
+                                [ "Error sharing DHTKey to " ++ show route
+                                , "  " ++ show e
+                                ]
                     forM_ soliciting $ \cksum@(NoSpam nospam _)-> do
                         dput XMan $ unwords [ take 8 (show $ key2id theirkey)
                                             , show (nodeAddr $ Tox.rendezvousNode rendezvous)