2 files changed, 76 insertions, 5 deletions

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 26e22361..2683d404 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP            #-}
-{-# LANGUAGE LambdaCase     #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE NondecreasingIndentation #-}
 module ToxToXMPP
     ( forkAccountWatcher
     , JabberClients
@@ -22,6 +23,7 @@ import Network.Tox.Crypto.Transport as Tox
 import Util                         (unsplitJID)
 import XMPPServer                   as XMPP
 
+import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest)
 import Announcer
 import Announcer.Tox
 import Connection
@@ -58,7 +60,7 @@ import Network.Tox
 import Network.Tox.ContactInfo
 import Network.Tox.DHT.Handlers
 import qualified Network.Tox.DHT.Transport   as Tox
-         ;import Network.Tox.DHT.Transport   (FriendRequest (..))
+         ;import Network.Tox.DHT.Transport   (dhtpk, FriendRequest (..))
 import Network.Tox.NodeId
 import qualified Network.Tox.Onion.Handlers  as Tox
 import qualified Network.Tox.Onion.Transport as Tox
@@ -144,13 +146,65 @@ data ToxToXMPP = ToxToXMPP
 default_nospam :: Word32
 default_nospam = 0x6a7a27fc -- big-endian base64: anon/A==
 
+nodeinfoStaleTime  :: POSIXTime
+nodeinfoStaleTime = 600
+
+nodeinfoSearchInterval :: POSIXTime
+nodeinfoSearchInterval = 15
+
+gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
+gotDhtPubkey pubkey tx theirKey = do
+  contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr)
+  forM_ contact $ \lastSeen -> do
+    case lastSeen of
+      Nothing -> doSearch
+      Just (tm, _) -> do
+        now <- getPOSIXTime
+        when (now - tm > nodeinfoStaleTime) doSearch
+  where
+    doSearch = do
+      let pub = toPublic $ userSecret (txAccount tx)
+          me = key2id pub
+      akey <- akeyConnect (txAnnouncer tx) me theirKey
+      atomically $ registerNodeCallback (toxRouting tox) (nic akey)
+      scheduleSearch (txAnnouncer tx) akey meth pubkey
+    tox :: Tox JabberClients
+    tox = txTox tx
+    target = key2id $ dhtpk pubkey
+    meth :: SearchMethod Tox.DHTPublicKey
+    meth =
+      SearchMethod
+      { sSearch       = nodeSearch (toxDHT tox) (nodesOfInterest $ toxRouting tox)
+      , sNearestNodes = nearNodes tox
+      , sTarget       = target
+      , sInterval     = nodeinfoSearchInterval
+      , sWithResult   = \r sr -> return ()
+      }
+    nic akey =
+      NodeInfoCallback
+      { interestingNodeId = target
+      , listenerId        = 2
+      , observedAddress   = observe akey
+      , rumoredAddress    = assume akey
+      }
+
+    assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM ()
+    assume akey time addr ni =
+      tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni)
+
+    observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM ()
+    observe akey time ni = do
+      tput XNodeinfoSearch $ show ("observation", akey, time, ni)
+      unschedule (txAnnouncer tx) akey -- todo: schedule the handshake here
+      setContactAddr time theirKey (nodeAddr ni) (txAccount tx)
+
 dispatch :: ToxToXMPP -> ContactEvent -> IO ()
 dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey
 dispatch tx (SessionTerminated theirKey)  = startConnecting tx theirKey
 dispatch tx (AddrChange   theirkey saddr)                    = return () -- todo
 dispatch tx (PolicyChange theirkey TryingToConnect         ) = startConnecting tx theirkey
 dispatch tx (PolicyChange theirkey policy                  ) = stopConnecting tx theirkey
-dispatch tx (OnionRouted  theirkey (OnionDHTPublicKey pkey)) = return () -- todo
+dispatch tx (OnionRouted  theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey
 dispatch tx (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
     let ToxToXMPP { txAnnouncer = acr
                   , txAccount   = acnt
@@ -189,6 +243,7 @@ akeyConnect :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey
 akeyConnect announcer me them = atomically $ do
     packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them)
 
+
 -- | Returns a list of nospam values to use for friend requests to send to a
 -- remote peer.  This list is non-empty only when it is desirable to send
 -- friend requests.
@@ -208,6 +263,16 @@ checkSoliciting presence me them contact = do
             _                -> maybeToList $ readMaybe $ T.unpack $ key2jid default_nospam them
         return nospam
 
+nearNodes :: Tox extra -> NodeId -> STM [NodeInfo]
+nearNodes tox nid = do
+  bkts4 <- readTVar $ routing4 $ toxRouting tox
+  bkts6 <- readTVar $ routing6 $ toxRouting tox
+  let nss =
+        map
+          (R.kclosest (searchSpace (toxQSearch tox)) searchK nid)
+          [bkts4, bkts6]
+  return $ foldr interweave [] nss
+
 startConnecting0 :: ToxToXMPP -> PublicKey -> Contact -> IO ()
 startConnecting0 tx them contact = do
         dput XMan $ "START CONNECTING " ++ show (key2id them)
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
index 5135813a..e76e2f1b 100644
--- a/src/Network/Tox/ContactInfo.hs
+++ b/src/Network/Tox/ContactInfo.hs
@@ -70,6 +70,12 @@ initContact = Contact <$> newTVar Nothing
                       <*> newTVar Nothing
                       <*> newTVar Nothing
 
+getContact :: PublicKey -> Account extra -> STM (Maybe Contact)
+getContact remoteUserKey acc = do
+    let rkey = key2id remoteUserKey
+    cmap <- readTVar (contacts acc)
+    return $ HashMap.lookup rkey cmap
+
 updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM ()
 updateAccount' remoteUserKey acc updater = do
     let rkey = key2id remoteUserKey