From f2016c7a77c077ec342a687a172a16bf64311709 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 19 May 2018 22:26:46 -0400 Subject: Auto-schedule DHT announce for toxmpp sessions. --- examples/dhtd.hs | 75 +++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 53 insertions(+), 22 deletions(-) (limited to 'examples/dhtd.hs') 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 -- cgit v1.2.3