diff options
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r-- | examples/dhtd.hs | 115 |
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 | ||
69 | import Announcer | 69 | import Announcer |
70 | import ToxManager | ||
70 | import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) | 71 | import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) |
71 | import Network.UPNP as UPNP | 72 | import Network.UPNP as UPNP |
72 | import Network.Address hiding (NodeId, NodeInfo(..)) | 73 | import 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 | ||
1303 | toxAnnounceSendData :: Tox.Tox -> PublicKey | ||
1304 | -> Nonce32 | ||
1305 | -> Maybe Tox.NodeInfo | ||
1306 | -> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse)) | ||
1307 | toxAnnounceSendData 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 | |||
1316 | toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous | ||
1317 | toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox) | ||
1318 | |||
1319 | toxAnnounceInterval :: POSIXTime | ||
1320 | toxAnnounceInterval = 15 | ||
1321 | |||
1322 | -- | | ||
1323 | -- | ||
1324 | -- These hooks will be invoked in order to connect to *.tox hosts in a user's | ||
1325 | -- XMPP roster. | ||
1326 | toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> PresenceState -> ToxManager ConnectionKey | ||
1327 | toxman 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. |
1419 | announceToxJabberPeer :: PublicKey -- ^ Remote tox node's long-term user key. | 1306 | announceToxJabberPeer :: PublicKey -- ^ Remote tox node's long-term user key. |