tox: Automatically share dhtkey with roster contacts.

5 files changed, 112 insertions, 22 deletions

diff --git a/ToxManager.hs b/ToxManager.hs
index aa838027..af1911d4 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -38,9 +38,6 @@ import Control.Concurrent.Lifted
 import GHC.Conc                  (labelThread)
 #endif
 
-toxAnnounceInterval :: POSIXTime
-toxAnnounceInterval = 15
-
 toxAnnounceSendData :: Tox.Tox -> PublicKey
                                -> Nonce32
                                -> Maybe Tox.NodeInfo
@@ -55,13 +52,6 @@ toxAnnounceSendData tox pubkey token = \case
     Nothing -> return Nothing
 
 
-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)
-
-interweave :: [a] -> [a] -> [a]
-interweave []     ys = ys
-interweave (x:xs) ys = x : interweave ys xs
-
 -- |
 --
 -- These hooks will be invoked in order to connect to *.tox hosts in a user's
@@ -100,7 +90,7 @@ toxman announcer toxbkts tox presence = ToxManager
                                      toxAnnounceInterval)
                      pub
 
-            forkAccountWatcher acnt tox presence
+            forkAccountWatcher acnt tox presence announcer
             return ()
 
     , deactivateAccount      = \k pubname -> do
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
+
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index d7a069b4..28bfc9b4 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1718,7 +1718,13 @@ main = runResourceT $ liftBaseWith $ \resT -> do
             forM_ msv $ \sv -> do
                 let Tox.HaveDHTKey saddr = Tox.ncSockAddr netcrypto
                 announceToxJabberPeer (Tox.ncTheirPublicKey netcrypto) (xmppEventChannel sv) addrTox saddr pingflag xmppSrc xmppSink
-            -- TODO: Update toxContactInfo, connected.
+                forM_ mbtox $ \tox -> do
+                let ContactInfo{accounts} = Tox.toxContactInfo tox
+                mbacc <- HashMap.lookup (Tox.key2id $ Tox.ncMyPublicKey netcrypto)
+                         <$> atomically (readTVar accounts)
+                forM_ mbacc $ \acnt -> do
+                now <- getPOSIXTime
+                atomically $ setEstablished now (Tox.ncTheirPublicKey netcrypto) acnt
             atomically $ do
                 supply <- readTVar (Tox.listenerIDSupply netCryptoSessionsState)
                 let (listenerId,supply') = freshId supply
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 5a4c02ea..52dba0f5 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -351,6 +351,7 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
                             hPutStrLn stderr "Unable to establish session..."
                             return []
 
+-- | Create a DHTPublicKey packet to send to a remote contact.
 getContactInfo :: Tox -> IO DHT.DHTPublicKey
 getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
     r4 <- readTVar $ DHT.routing4 toxRouting
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
index 47c07237..9f29d587 100644
--- a/src/Network/Tox/ContactInfo.hs
+++ b/src/Network/Tox/ContactInfo.hs
@@ -34,6 +34,8 @@ data Account = Account
 data ContactEvent = OnionRouted  { contact :: PublicKey, onionRouted :: OnionData }
                   | PolicyChange { contact :: PublicKey, policyChange :: Policy }
                   | AddrChange   { contact :: PublicKey, addrChange :: SockAddr }
+                  | SessionEstablished { contact :: PublicKey }
+                  | SessionTerminated  { contact :: PublicKey }
 
 data Contact = Contact
     { contactKeyPacket     :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
@@ -105,6 +107,13 @@ setContactAddr now remoteUserKey addr acc = do
     updateAccount' remoteUserKey acc $ addrUpdate now addr
     writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
 
+setEstablished :: POSIXTime -> PublicKey -> Account -> STM ()
+setEstablished now remoteUserKey acc =
+    writeTChan (eventChan acc) $ SessionEstablished remoteUserKey
+
+setTerminated :: POSIXTime -> PublicKey -> Account -> STM ()
+setTerminated now remoteUserKey acc =
+    writeTChan (eventChan acc) $ SessionTerminated remoteUserKey
 
 
 addContactInfo :: ContactInfo -> SecretKey -> STM ()