Auto-schedule DHT announce for toxmpp sessions.

1 files changed, 53 insertions, 22 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 0439ed7e..b3c60015 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1067,27 +1067,61 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue, ncPacketQueue }) = C.awaitFo
         sendit session Flush = return ()
     liftIO $ sendit session flush_cyptomessage
 
--- | TODO
+
+toxAnnounceSendData :: Tox.Tox -> PublicKey
+                               -> Nonce32
+                               -> Maybe Tox.NodeInfo
+                               -> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse))
+toxAnnounceSendData tox pubkey token = \case
+    Just ni -> Tox.putRendezvous (Tox.onionTimeout tox)
+                                 (Tox.toxCryptoKeys tox)
+                                 (Tox.toxOnion tox)
+                                 (pubkey :: PublicKey)
+                                 (token :: Nonce32)
+                                 ni
+    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)
+
+toxAnnounceInterval :: POSIXTime
+toxAnnounceInterval = 15
+
+-- |
 --
 -- These hooks will be invoked in order to connect to *.tox hosts in a user's
 -- XMPP roster.
-toxman :: Tox.Tox -> ToxManager ConnectionKey
-toxman tox = ToxManager
+toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> ToxManager ConnectionKey
+toxman announcer toxbkts tox = ToxManager
     { activateAccount        = \k pubname seckey -> do
         hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
-        atomically $ do
         let ContactInfo{ accounts } = Tox.toxContactInfo tox
             pub = toPublic seckey
             pubid = Tox.key2id pub
-        refs <- do
+        newlyActive <- atomically $ do
             macnt <- HashMap.lookup pubid <$> readTVar accounts
             acnt <- maybe (newAccount seckey) return macnt
             rs <- readTVar $ clientRefs acnt
             writeTVar (clientRefs acnt) $! Set.insert k rs
             modifyTVar accounts (HashMap.insert pubid acnt)
-            return rs
-        when (Set.null refs) $ do
+            if not (Set.null rs)
+                then return []
+                else do
+                    forM toxbkts $ \(nm,bkts) -> do
+                        akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
+                        return (akey,bkts)
+        forM_ newlyActive $ \(akey,bkts) -> do
             -- Schedule recurring announce.
+            --
+            schedule announcer
+                     akey
+                     (AnnounceMethod (toxQSearch tox)
+                                     (Right $ toxAnnounceSendData tox)
+                                     bkts
+                                     pubid
+                                     toxAnnounceInterval)
+                     pub
+            --
             -- Schedule recurring search for all non-connected contacts.
             return ()
     , deactivateAccount      = \k pubname -> atomically $ do
@@ -1293,9 +1327,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                                         , qshowTok = (const Nothing)
                                         })
                                     , ("toxid", DHTQuery
-                                        { qsearch = (Tox.toxidSearch (Tox.onionTimeout tox)
-                                                                          (Tox.toxCryptoKeys tox)
-                                                                          (Tox.toxOnion tox))
+                                        { qsearch = toxQSearch tox
                                         , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
                                                          (\ni nid ->
                                                             Tox.unwrapAnnounceResponse Nothing
@@ -1313,16 +1345,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                     , dhtSearches = toxSearches
                     , dhtFallbackNodes = return []
                     , dhtAnnouncables = Map.fromList
-                                    [ ("toxid", DHTAnnouncable { announceSendData = Right $ \pubkey token -> \case
-                                                                    Just ni ->
-                                                                        Tox.putRendezvous
-                                                                            (Tox.onionTimeout tox)
-                                                                            (Tox.toxCryptoKeys tox)
-                                                                            (Tox.toxOnion tox)
-                                                                            (pubkey :: PublicKey)
-                                                                            (token :: Nonce32)
-                                                                            ni
-                                                                    Nothing -> return Nothing
+                                    [ ("toxid", DHTAnnouncable { announceSendData = Right (toxAnnounceSendData tox)
                                                                , announceParseAddress = readEither
                                                                , announceParseToken = const $ readEither
                                                                , announceParseData = fmap Tox.id2key . readEither
@@ -1340,7 +1363,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                     -- 15 seconds later. Toxcore sends every announce packet
                     -- with the `ping_id` previously received from that peer
                     -- with the same path (if possible).
-                                                               , announceInterval = 15
+                                                               , announceInterval = toxAnnounceInterval
 
                                                                })
                                     -- dhtkey parameters:
@@ -1451,7 +1474,15 @@ main = runResourceT $ liftBaseWith $ \resT -> do
             -- XMPP initialization
             cw        <- newConsoleWriter
             serverVar <- atomically $ newEmptyTMVar
-            state     <- newPresenceState cw (toxman <$> mbtox) serverVar
+            let lookupBkts :: String -> Map.Map String DHT -> Maybe (String,TVar (BucketList Tox.NodeInfo))
+                lookupBkts name m = case Map.lookup name m of
+                    Nothing              -> Nothing
+                    Just DHT{dhtBuckets} -> cast (name, dhtBuckets)
+            let toxbkts = catMaybes
+                            [ lookupBkts "tox4" toxdhts
+                            , lookupBkts "tox6" toxdhts
+                            ]
+            state     <- newPresenceState cw (toxman announcer toxbkts <$> mbtox) serverVar
 
             sv    <- resT $ xmppServer (presenceHooks state (verbosity opts) Nothing)
             -- We now have a server object but it's not ready to use until