summaryrefslogtreecommitdiff
path: root/examples/dhtd.hs
diff options
context:
space:
mode:
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r--examples/dhtd.hs115
1 files changed, 1 insertions, 114 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 56d9544d..28e9f261 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -67,6 +67,7 @@ import System.Posix.Signals
67 67
68 68
69import Announcer 69import Announcer
70import ToxManager
70import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) 71import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
71import Network.UPNP as UPNP 72import Network.UPNP as UPNP
72import Network.Address hiding (NodeId, NodeInfo(..)) 73import Network.Address hiding (NodeId, NodeInfo(..))
@@ -1300,120 +1301,6 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar, ncPacketQueue
1300 liftIO $ sendit session flush_cyptomessage 1301 liftIO $ sendit session flush_cyptomessage
1301 1302
1302 1303
1303toxAnnounceSendData :: Tox.Tox -> PublicKey
1304 -> Nonce32
1305 -> Maybe Tox.NodeInfo
1306 -> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse))
1307toxAnnounceSendData tox pubkey token = \case
1308 Just ni -> Tox.putRendezvous (Tox.onionTimeout tox)
1309 (Tox.toxCryptoKeys tox)
1310 (Tox.toxOnion tox)
1311 (pubkey :: PublicKey)
1312 (token :: Nonce32)
1313 ni
1314 Nothing -> return Nothing
1315
1316toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous
1317toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox)
1318
1319toxAnnounceInterval :: POSIXTime
1320toxAnnounceInterval = 15
1321
1322-- |
1323--
1324-- These hooks will be invoked in order to connect to *.tox hosts in a user's
1325-- XMPP roster.
1326toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> PresenceState -> ToxManager ConnectionKey
1327toxman announcer toxbkts tox presence = ToxManager
1328 { activateAccount = \k pubname seckey -> do
1329 hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
1330 let ContactInfo{ accounts } = Tox.toxContactInfo tox
1331 pub = toPublic seckey
1332 pubid = Tox.key2id pub
1333 (acnt,newlyActive) <- atomically $ do
1334 macnt <- HashMap.lookup pubid <$> readTVar accounts
1335 acnt <- maybe (newAccount seckey) return macnt
1336 rs <- readTVar $ clientRefs acnt
1337 writeTVar (clientRefs acnt) $! Set.insert k rs
1338 modifyTVar accounts (HashMap.insert pubid acnt)
1339 if not (Set.null rs)
1340 then return (acnt,[])
1341 else do
1342 fmap ((,) acnt) $ forM toxbkts $ \(nm,bkts) -> do
1343 akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
1344 return (akey,bkts)
1345 forM_ newlyActive $ \(akey,bkts) -> do
1346 -- Schedule recurring announce.
1347 --
1348 schedule announcer
1349 akey
1350 (AnnounceMethod (toxQSearch tox)
1351 (Right $ toxAnnounceSendData tox)
1352 bkts
1353 pubid
1354 toxAnnounceInterval)
1355 pub
1356
1357 forkAccountWatcher acnt tox presence
1358 return ()
1359
1360 , deactivateAccount = \k pubname -> do
1361 hPutStrLn stderr $ "toxman DECTIVATE (todo) 1 " ++ show pubname
1362 let ContactInfo{ accounts } = Tox.toxContactInfo tox
1363 mpubid = readMaybe $ T.unpack $ T.take 43 pubname
1364 bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
1365 forM mpubid $ \pubid -> do
1366 refs <- do
1367 macnt <- HashMap.lookup pubid <$> readTVar accounts
1368 rs <- fromMaybe Set.empty <$> mapM (readTVar . clientRefs) macnt
1369 forM_ macnt $ \acnt -> do
1370 modifyTVar' (clientRefs acnt) $ Set.delete k
1371 return rs
1372 if (Set.null $ refs Set.\\ Set.singleton k) then do
1373 -- TODO
1374 -- If this is the last reference to a non-connected contact:
1375 -- Stop the recurring search for that contact
1376 --
1377 -- Stop recurring announce.
1378 fmap Just $ forM toxbkts $ \(nm,bkts) -> do
1379 akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
1380 return (akey,bkts)
1381 else return Nothing
1382 forM_ bStopped $ \kbkts -> do
1383 hPutStrLn stderr $ "toxman DECTIVATE (todo) 3 " ++ show pubname
1384 let Just pubid = mpubid
1385 pub = Tox.id2key pubid
1386 forM_ kbkts $ \(akey,bkts) -> do
1387 cancel announcer
1388 akey
1389 (AnnounceMethod (toxQSearch tox)
1390 (Right $ toxAnnounceSendData tox)
1391 bkts
1392 pubid
1393 toxAnnounceInterval)
1394 pub
1395
1396 , setToxConnectionPolicy = \me them p -> do
1397 let m = do meid <- readMaybe $ T.unpack $ T.take 43 me
1398 themid <- readMaybe $ T.unpack $ T.take 43 them
1399 return $ Tox.Key meid themid
1400 hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p,fmap (const ()) m)
1401 forM_ m $ \k -> do
1402 setPolicy (Tox.toxMgr tox) k p
1403 case p of
1404 TryingToConnect -> do
1405 let db@ContactInfo{ accounts } = Tox.toxContactInfo tox
1406 sequence_ $ do
1407 let Tox.Key meid themid = k
1408 Just $ atomically $ do
1409 accs <- readTVar accounts
1410 case HashMap.lookup meid accs of
1411 Nothing -> return () -- Unknown account.
1412 Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc
1413 -- If unscheduled and unconnected, schedule recurring search for this contact.
1414 _ -> return () -- Remove contact.
1415 }
1416
1417-- | Called upon a new Tox friend-connection session with a remote peer in 1304-- | Called upon a new Tox friend-connection session with a remote peer in
1418-- order to set up translating conduits that simulate a remote XMPP server. 1305-- order to set up translating conduits that simulate a remote XMPP server.
1419announceToxJabberPeer :: PublicKey -- ^ Remote tox node's long-term user key. 1306announceToxJabberPeer :: PublicKey -- ^ Remote tox node's long-term user key.