tox: Automatically share dhtkey with roster contacts.

1 files changed, 94 insertions, 10 deletions

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index edbf35ca..ac24ce6d 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP            #-}
+{-# LANGUAGE LambdaCase     #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module ToxToXMPP where
 
 import Data.Conduit                 as C
@@ -9,23 +10,52 @@ import Network.Tox.Crypto.Transport as Tox
 import XMPPServer                   as XMPP
 import EventUtil
 
+import Announcer
+import Announcer.Tox
+import Connection
+import Network.QueryResponse
+-- import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.Tox
+import qualified Data.HashMap.Strict         as HashMap
+import Data.Maybe
+import qualified Data.Set                    as Set
+import qualified Data.Text                   as T
+import Data.Time.Clock.POSIX
+import Network.Address
+import Network.Kademlia.Search
+import qualified Network.Tox                 as Tox
+import Network.Tox.ContactInfo               as Tox
+import qualified Network.Tox.Crypto.Handlers as Tox
+-- import qualified Network.Tox.DHT.Handlers    as Tox
+import Announcer
 import ClientState
 import Control.Concurrent.STM
 import Control.Monad
 import Crypto.Tox
 import Data.Bits
 import Data.Function
-import qualified Data.Map            as Map
-import qualified Data.Set            as Set
-import qualified Data.Text           as T
-         ;import Data.Text           (Text)
+import qualified Data.Map                    as Map
+import qualified Data.Set                    as Set
+import qualified Data.Text                   as T
+         ;import Data.Text                   (Text)
 import Data.Word
+import qualified Network.Kademlia.Routing    as R
 import Network.Tox
 import Network.Tox.ContactInfo
-import Network.Tox.DHT.Transport     (FriendRequest (..))
+import Network.Tox.DHT.Handlers
+import qualified Network.Tox.DHT.Transport   as Tox
+         ;import Network.Tox.DHT.Transport   (FriendRequest (..))
 import Network.Tox.NodeId
-import Network.Tox.Onion.Transport   (OnionData (..))
+import qualified Network.Tox.Onion.Handlers  as Tox
+import qualified Network.Tox.Onion.Transport as Tox
+         ;import Network.Tox.Onion.Transport (OnionData (..))
+import Presence
 import Presence
+import System.IO
+import Text.Read
+import XMPPServer                            (ConnectionKey)
 #ifdef THREAD_DEBUG
 import Control.Concurrent.Lifted.Instrument
 #else
@@ -93,8 +123,13 @@ dispatch acnt st (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
         -- embed it in the stanza as a <status> element.
         sendModifiedStanzaToClient ask (connChan conn)
 
-forkAccountWatcher :: Account -> Tox -> PresenceState -> IO ThreadId
-forkAccountWatcher acc tox st = forkIO $ do
+interweave :: [a] -> [a] -> [a]
+interweave []     ys = ys
+interweave (x:xs) ys = x : interweave ys xs
+
+
+forkAccountWatcher :: Account -> Tox -> PresenceState -> Announcer -> IO ThreadId
+forkAccountWatcher acc tox st announcer = forkIO $ do
     myThreadId >>= flip labelThread ("tox-xmpp:"
                                       ++ show (key2id $ toPublic $ userSecret acc))
     (chan,contacts) <- atomically $ do
@@ -103,6 +138,49 @@ forkAccountWatcher acc tox st = forkIO $ do
                 return (chan,contacts)
     -- TODO: process information in contacts HashMap.
 
+    let nearNodes 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
+
+
+    forM_ (HashMap.toList contacts) $ \(them,Contact{contactPolicy}) -> do
+        wanted <- atomically $ (==Just TryingToConnect) <$> readTVar contactPolicy
+        when wanted $ do
+            let pub = toPublic $ userSecret acc
+            akey <- atomically $ packAnnounceKey announcer $ "dhtkey:" ++ show them
+                    -- We send this packet every 30 seconds if there is more
+                    -- than one peer (in the 8) that says they our friend is
+                    -- announced on them. This packet can also be sent through
+                    -- the DHT module as a DHT request packet (see DHT) if we
+                    -- know the DHT public key of the friend and are looking
+                    -- for them in the DHT but have not connected to them yet.
+                    -- 30 second is a reasonable timeout to not flood the
+                    -- network with too many packets while making sure the
+                    -- other will eventually receive the packet. Since packets
+                    -- are sent through every peer that knows the friend,
+                    -- resending it right away without waiting has a high
+                    -- likelihood of failure as the chances of packet loss
+                    -- happening to all (up to to 8) packets sent is low.
+                    --
+            schedule announcer
+                     akey
+                     (AnnounceMethod (toxQSearch tox)
+                                     (Left $ \theirkey rendezvous -> do
+                                        dkey <- Tox.getContactInfo tox
+                                        sendMessage
+                                            (Tox.toxToRoute tox)
+                                            (Tox.AnnouncedRendezvous theirkey rendezvous)
+                                            (pub,Tox.OnionDHTPublicKey dkey))
+                                     nearNodes
+                                     them
+                                     30) -- every 30 seconds
+                     pub
+
+
+
     -- Loop endlessly until clientRefs is null.
     fix $ \loop -> do
     mev <- atomically $
@@ -113,3 +191,9 @@ forkAccountWatcher acc tox st = forkIO $ do
                 return Nothing
     forM_ mev $ \ev -> dispatch acc st ev >> loop
 
+toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous
+toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox)
+
+toxAnnounceInterval :: POSIXTime
+toxAnnounceInterval = 15
+