diff options
Diffstat (limited to 'ToxManager.hs')
-rw-r--r-- | ToxManager.hs | 464 |
1 files changed, 455 insertions, 9 deletions
diff --git a/ToxManager.hs b/ToxManager.hs index 6d0149cf..6fb13c21 100644 --- a/ToxManager.hs +++ b/ToxManager.hs | |||
@@ -1,33 +1,59 @@ | |||
1 | {-# LANGUAGE CPP #-} | 1 | {-# LANGUAGE CPP #-} |
2 | {-# LANGUAGE LambdaCase #-} | 2 | {-# LANGUAGE LambdaCase #-} |
3 | {-# LANGUAGE NamedFieldPuns #-} | 3 | {-# LANGUAGE NamedFieldPuns #-} |
4 | {-# LANGUAGE NondecreasingIndentation #-} | ||
5 | {-# LANGUAGE ViewPatterns #-} | ||
6 | |||
4 | module ToxManager where | 7 | module ToxManager where |
5 | 8 | ||
6 | import Announcer | 9 | import Announcer |
7 | import Announcer.Tox | 10 | import Announcer.Tox |
11 | import ClientState | ||
8 | import Connection | 12 | import Connection |
9 | -- import Control.Concurrent | ||
10 | import Control.Concurrent.STM | 13 | import Control.Concurrent.STM |
11 | import Control.Monad | 14 | import Control.Monad |
12 | import Crypto.Tox | 15 | import Crypto.Tox |
16 | import Data.Bits | ||
17 | import Data.Function | ||
13 | import qualified Data.HashMap.Strict as HashMap | 18 | import qualified Data.HashMap.Strict as HashMap |
14 | import qualified Data.Map as Map | 19 | import qualified Data.Map as Map |
15 | import Data.Maybe | 20 | import Data.Maybe |
21 | import qualified Data.Set as Set | ||
16 | import qualified Data.Text as T | 22 | import qualified Data.Text as T |
17 | import Network.Kademlia.Routing as R | 23 | ;import Data.Text (Text) |
24 | import Data.Time.Clock.POSIX | ||
25 | import Data.Word | ||
26 | import DPut | ||
27 | import Network.Address | ||
28 | import qualified Network.Kademlia.Routing as R | ||
29 | ;import Network.Kademlia.Routing as R | ||
18 | import Network.Kademlia.Search | 30 | import Network.Kademlia.Search |
31 | import Network.QueryResponse | ||
19 | import qualified Network.Tox as Tox | 32 | import qualified Network.Tox as Tox |
33 | ;import Network.Tox | ||
20 | import Network.Tox.ContactInfo as Tox | 34 | import Network.Tox.ContactInfo as Tox |
21 | import qualified Network.Tox.Crypto.Handlers as Tox | 35 | import qualified Network.Tox.Crypto.Handlers as Tox |
22 | -- import qualified Network.Tox.DHT.Handlers as Tox | 36 | ;import Network.Tox.Crypto.Handlers (UponCookie (..)) |
37 | import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest) | ||
38 | import Network.Tox.DHT.Handlers | ||
23 | import qualified Network.Tox.DHT.Transport as Tox | 39 | import qualified Network.Tox.DHT.Transport as Tox |
40 | ;import Network.Tox.DHT.Transport (FriendRequest (..), dhtpk) | ||
41 | import Network.Tox.Handshake (HandshakeParams (..)) | ||
42 | import Network.Tox.NodeId | ||
24 | import qualified Network.Tox.Onion.Handlers as Tox | 43 | import qualified Network.Tox.Onion.Handlers as Tox |
25 | import qualified Network.Tox.Onion.Transport as Tox | 44 | import qualified Network.Tox.Onion.Transport as Tox |
45 | ;import Network.Tox.Onion.Transport (OnionData (..)) | ||
26 | import Presence | 46 | import Presence |
27 | import Text.Read | 47 | import Text.Read |
28 | import ToxToXMPP | 48 | import Util (unsplitJID) |
29 | import XMPPServer | 49 | import XMPPServer as XMPP |
30 | import DPut | 50 | #ifdef THREAD_DEBUG |
51 | import Control.Concurrent.Lifted.Instrument | ||
52 | #else | ||
53 | import Control.Concurrent.Lifted | ||
54 | import GHC.Conc (labelThread) | ||
55 | #endif | ||
56 | |||
31 | 57 | ||
32 | 58 | ||
33 | toxAnnounceSendData :: Tox.Tox JabberClients | 59 | toxAnnounceSendData :: Tox.Tox JabberClients |
@@ -154,3 +180,423 @@ toxman announcer toxbkts tox presence = ToxManager | |||
154 | return $ addrToPeerKey . Remote . Tox.nodeAddr . snd <$> maddr | 180 | return $ addrToPeerKey . Remote . Tox.nodeAddr . snd <$> maddr |
155 | } | 181 | } |
156 | 182 | ||
183 | key2jid :: Word32 -> PublicKey -> Text | ||
184 | key2jid nospam key = T.pack $ show $ NoSpamId nsp key | ||
185 | where | ||
186 | nsp = NoSpam nospam (Just sum) | ||
187 | sum = nlo `xor` nhi `xor` xorsum key | ||
188 | nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 | ||
189 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 | ||
190 | |||
191 | type JabberClients = Map.Map ClientAddress PerClient | ||
192 | |||
193 | data PerClient = PerClient | ||
194 | { pcDeliveredFRs :: TVar (Set.Set Tox.FriendRequest) | ||
195 | } | ||
196 | |||
197 | initPerClient :: STM PerClient | ||
198 | initPerClient = do | ||
199 | frs <- newTVar Set.empty | ||
200 | return PerClient | ||
201 | { pcDeliveredFRs = frs | ||
202 | } | ||
203 | |||
204 | data ToxToXMPP = ToxToXMPP | ||
205 | { txAnnouncer :: Announcer | ||
206 | , txAccount :: Account JabberClients | ||
207 | , txPresence :: PresenceState | ||
208 | , txTox :: Tox JabberClients | ||
209 | } | ||
210 | |||
211 | default_nospam :: Word32 | ||
212 | default_nospam = 0x6a7a27fc -- big-endian base64: anon/A== | ||
213 | |||
214 | nodeinfoStaleTime :: POSIXTime | ||
215 | nodeinfoStaleTime = 600 | ||
216 | |||
217 | nodeinfoSearchInterval :: POSIXTime | ||
218 | nodeinfoSearchInterval = 15 | ||
219 | |||
220 | data Awaiting v = Since POSIXTime | ||
221 | data Acquired v = At POSIXTime v | ||
222 | data Moot v = Moot | ||
223 | |||
224 | data NNS a b c = NNS { -- NetcryptoNegotiationState | ||
225 | sessionDesired :: Bool, | ||
226 | theirPublicKey :: a Tox.DHTPublicKey, | ||
227 | theirAddress :: b NodeInfo, | ||
228 | theirCookie :: c (Tox.Cookie Encrypted), | ||
229 | sessionIsActive :: Bool | ||
230 | } | ||
231 | |||
232 | data NS | ||
233 | = Stage1 (NNS Moot Moot Moot) | ||
234 | | Stage2 (NNS Awaiting Moot Moot) | ||
235 | | Stage3 (NNS Acquired Awaiting Moot) | ||
236 | | Stage4 (NNS Acquired Acquired Awaiting) | ||
237 | | Stage5 (NNS Acquired Acquired Acquired) | ||
238 | |||
239 | gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () | ||
240 | gotDhtPubkey theirDhtKey tx theirKey = do | ||
241 | contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr) | ||
242 | forM_ contact $ \lastSeen -> do | ||
243 | case lastSeen of | ||
244 | Nothing -> doSearch | ||
245 | Just (tm, _) -> do | ||
246 | now <- getPOSIXTime | ||
247 | when (now - tm > nodeinfoStaleTime) doSearch | ||
248 | where | ||
249 | tox :: Tox JabberClients | ||
250 | tox = txTox tx | ||
251 | |||
252 | myPublicKey = toPublic $ userSecret (txAccount tx) | ||
253 | me = key2id myPublicKey | ||
254 | |||
255 | doSearch = do | ||
256 | let akey = akeyConnect (txAnnouncer tx) me theirKey | ||
257 | atomically $ registerNodeCallback (toxRouting tox) (nic akey) | ||
258 | scheduleSearch (txAnnouncer tx) akey meth theirDhtKey | ||
259 | |||
260 | target :: NodeId | ||
261 | target = key2id $ dhtpk theirDhtKey | ||
262 | |||
263 | meth :: SearchMethod Tox.DHTPublicKey | ||
264 | meth = | ||
265 | SearchMethod | ||
266 | { sSearch = nodeSearch (toxDHT tox) (nodesOfInterest $ toxRouting tox) | ||
267 | , sNearestNodes = nearNodes tox | ||
268 | , sTarget = target | ||
269 | , sInterval = nodeinfoSearchInterval | ||
270 | , sWithResult = \r sr -> return () | ||
271 | } | ||
272 | nic akey = | ||
273 | NodeInfoCallback | ||
274 | { interestingNodeId = target | ||
275 | , listenerId = 2 | ||
276 | , observedAddress = observe akey | ||
277 | , rumoredAddress = assume akey | ||
278 | } | ||
279 | |||
280 | assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM () | ||
281 | assume akey time addr ni = | ||
282 | tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni) | ||
283 | |||
284 | observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () | ||
285 | observe akey time ni@(nodeAddr -> addr) = do | ||
286 | tput XNodeinfoSearch $ show ("observation", akey, time, addr) | ||
287 | setContactAddr time theirKey ni (txAccount tx) | ||
288 | |||
289 | gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO () | ||
290 | gotAddr ni@(nodeAddr -> addr) tx theirKey = do | ||
291 | dhtkey <- (fmap.fmap) snd $ | ||
292 | fmap join $ | ||
293 | atomically $ | ||
294 | traverse readTVar =<< fmap contactKeyPacket <$> getContact theirKey (txAccount tx) | ||
295 | forM_ dhtkey $ gotAddr' ni tx theirKey | ||
296 | |||
297 | gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO () | ||
298 | gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee | ||
299 | |||
300 | where | ||
301 | myPublicKey = toPublic $ userSecret (txAccount tx) | ||
302 | me = key2id myPublicKey | ||
303 | akey = akeyConnect (txAnnouncer tx) me theirKey | ||
304 | |||
305 | blee = do | ||
306 | scheduleImmediately (txAnnouncer tx) akey $ | ||
307 | ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) | ||
308 | |||
309 | tox :: Tox JabberClients | ||
310 | tox = txTox tx | ||
311 | |||
312 | byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) | ||
313 | byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) | ||
314 | |||
315 | crypto = Tox.transportCrypto $ toxCryptoSessions tox | ||
316 | |||
317 | readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) | ||
318 | readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr | ||
319 | |||
320 | chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) | ||
321 | chillSesh = readNcVar Tox.ncState | ||
322 | |||
323 | activeSesh :: SockAddr -> STM Bool | ||
324 | activeSesh a = chillSesh a >>= return . \case | ||
325 | Just Established -> True | ||
326 | _ -> False | ||
327 | |||
328 | readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) | ||
329 | readCookie = readNcVar Tox.ncCookie | ||
330 | readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) | ||
331 | readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie | ||
332 | |||
333 | client :: Network.Tox.DHT.Handlers.Client | ||
334 | client = toxDHT tox | ||
335 | |||
336 | getCookie | ||
337 | :: NodeInfo | ||
338 | -> STM Bool | ||
339 | -> STM (Maybe Contact) | ||
340 | -> Announcer | ||
341 | -> AnnounceKey | ||
342 | -> POSIXTime | ||
343 | -> STM (IO ()) | ||
344 | getCookie ni isActive getC ann akey now = getCookieAgain | ||
345 | where | ||
346 | getCookieAgain = do | ||
347 | tput XNodeinfoSearch $ show ("getCookieAgain", akey) | ||
348 | mbContact <- getC | ||
349 | case mbContact of | ||
350 | Nothing -> return $ return () | ||
351 | Just contact -> do | ||
352 | active <- isActive | ||
353 | return $ when (not active) getCookieIO | ||
354 | |||
355 | callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) | ||
356 | |||
357 | reschedule n f = scheduleRel ann akey f n | ||
358 | reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) | ||
359 | |||
360 | cookieMaxAge = 60 * 5 | ||
361 | |||
362 | getCookieIO :: IO () | ||
363 | getCookieIO = do | ||
364 | dput XUnused "getCookieIO - entered" | ||
365 | cookieRequest crypto client myPublicKey ni >>= \case | ||
366 | Nothing -> atomically $ reschedule' 5 (const getCookieAgain) | ||
367 | Just cookie -> do | ||
368 | void $ callRealShakeHands cookie | ||
369 | cookieCreationStamp <- getPOSIXTime | ||
370 | let shaker :: POSIXTime -> STM (IO ()) | ||
371 | shaker now = do | ||
372 | active <- isActive | ||
373 | if (active) | ||
374 | then return $ return () | ||
375 | else if (now > cookieCreationStamp + cookieMaxAge) | ||
376 | then return $ | ||
377 | dput XUnused "getCookieIO/shaker - cookie expired" >> | ||
378 | getCookieIO | ||
379 | else do | ||
380 | reschedule' 5 shaker | ||
381 | return . void $ callRealShakeHands cookie | ||
382 | atomically $ reschedule' 5 shaker | ||
383 | |||
384 | realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool | ||
385 | realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do | ||
386 | dput XUnused "realShakeHands" | ||
387 | let hp = | ||
388 | HParam | ||
389 | { hpOtherCookie = cookie | ||
390 | , hpMySecretKey = myseckey | ||
391 | , hpCookieRemotePubkey = theirpubkey | ||
392 | , hpCookieRemoteDhtkey = theirDhtKey | ||
393 | , hpTheirBaseNonce = Nothing | ||
394 | , hpTheirSessionKeyPublic = Nothing | ||
395 | } | ||
396 | newsession <- generateSecretKey | ||
397 | timestamp <- getPOSIXTime | ||
398 | (myhandshake, ioAction) <- | ||
399 | atomically $ | ||
400 | Tox.freshCryptoSession allsessions saddr newsession timestamp hp | ||
401 | ioAction | ||
402 | -- send handshake | ||
403 | isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr) | ||
404 | |||
405 | dispatch :: ToxToXMPP -> ContactEvent -> IO () | ||
406 | dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey "established" | ||
407 | dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey "terminated" | ||
408 | dispatch tx (AddrChange theirKey saddr) = gotAddr saddr tx theirKey | ||
409 | dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey "policy" | ||
410 | dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey "policy" | ||
411 | dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey | ||
412 | dispatch tx (OnionRouted theirkey (OnionFriendRequest fr) ) = do | ||
413 | let ToxToXMPP { txAnnouncer = acr | ||
414 | , txAccount = acnt | ||
415 | , txPresence = st } = tx | ||
416 | k2c <- atomically $ do | ||
417 | refs <- readTVar (accountExtra acnt) | ||
418 | k2c <- Map.intersectionWith (,) refs <$> readTVar (ckeyToChan st) | ||
419 | clients <- readTVar (clients st) | ||
420 | return $ Map.intersectionWith (,) k2c clients | ||
421 | -- TODO: Below we're using a hard coded default as their jabber user id. | ||
422 | -- This isn't the right thing, but we don't know their user-id. Perhaps | ||
423 | -- there should be a way to parse it out of the friend request text. Maybe | ||
424 | -- after a zero-termination, or as visible text (nospam:...). | ||
425 | let theirjid = key2jid default_nospam theirkey | ||
426 | forM_ k2c $ \((PerClient{pcDeliveredFRs},conn),client) -> do | ||
427 | alreadyDelivered <- atomically $ do | ||
428 | frs <- readTVar pcDeliveredFRs | ||
429 | writeTVar pcDeliveredFRs $ Set.insert fr frs | ||
430 | return $ Set.member fr frs | ||
431 | when (not alreadyDelivered) $ do | ||
432 | self <- localJID (clientUser client) (clientProfile client) (clientResource client) | ||
433 | ask <- presenceSolicitation theirjid self | ||
434 | -- TODO Send friend-request text as an instant message or at least | ||
435 | -- embed it in the stanza as a <status> element. | ||
436 | sendModifiedStanzaToClient ask (connChan conn) | ||
437 | |||
438 | interweave :: [a] -> [a] -> [a] | ||
439 | interweave [] ys = ys | ||
440 | interweave (x:xs) ys = x : interweave ys xs | ||
441 | |||
442 | akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey | ||
443 | akeyDHTKeyShare announcer me them = | ||
444 | packAnnounceKey announcer $ "dhtkey(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) | ||
445 | |||
446 | akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey | ||
447 | akeyConnect announcer me them = | ||
448 | packAnnounceKey announcer $ "connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) | ||
449 | |||
450 | |||
451 | -- | Returns a list of nospam values to use for friend requests to send to a | ||
452 | -- remote peer. This list is non-empty only when it is desirable to send | ||
453 | -- friend requests. | ||
454 | checkSoliciting :: PresenceState -> PublicKey -> PublicKey -> Contact -> IO [NoSpam] | ||
455 | checkSoliciting presence me them contact = do | ||
456 | let theirhost = T.pack $ show (key2id them) ++ ".tox" | ||
457 | myhost = T.pack $ show (key2id me) ++ ".tox" | ||
458 | xs <- getBuddiesAndSolicited presence myhost $ \h -> do | ||
459 | return $ T.toLower h == T.toLower theirhost | ||
460 | return $ do | ||
461 | (is_buddy,their_u,my_uid,xmpp_client_profile) <- xs | ||
462 | guard $ xmpp_client_profile == myhost | ||
463 | NoSpamId nospam _ <- case fmap T.unpack $ their_u of | ||
464 | Just ('$':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing) | ||
465 | Just ('0':'x':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing) | ||
466 | _ -> maybeToList $ readMaybe $ T.unpack $ key2jid default_nospam them | ||
467 | return nospam | ||
468 | |||
469 | nearNodes :: Tox extra -> NodeId -> STM [NodeInfo] | ||
470 | nearNodes tox nid = do | ||
471 | bkts4 <- readTVar $ routing4 $ toxRouting tox | ||
472 | bkts6 <- readTVar $ routing6 $ toxRouting tox | ||
473 | let nss = | ||
474 | map | ||
475 | (R.kclosest (searchSpace (toxQSearch tox)) searchK nid) | ||
476 | [bkts4, bkts6] | ||
477 | return $ foldr interweave [] nss | ||
478 | |||
479 | startConnecting0 :: ToxToXMPP -> PublicKey -> Contact -> String -> IO () | ||
480 | startConnecting0 tx them contact reason = do | ||
481 | dput XMan $ "START CONNECTING " ++ show (key2id them) ++ "("++reason++")" | ||
482 | -- TODO When a connection is already established, this function should | ||
483 | -- be a no-op. This occurs when an XMPP client disconnects and | ||
484 | -- reconnects while a session is established. | ||
485 | let ToxToXMPP { txTox = tox | ||
486 | , txAnnouncer = announcer | ||
487 | , txAccount = acnt } = tx | ||
488 | let nearNodes nid = do | ||
489 | bkts4 <- readTVar $ routing4 $ toxRouting tox | ||
490 | bkts6 <- readTVar $ routing6 $ toxRouting tox | ||
491 | let nss = map (R.kclosest (searchSpace (toxQSearch tox)) searchK nid) | ||
492 | [bkts4,bkts6] | ||
493 | return $ foldr interweave [] nss | ||
494 | wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact) | ||
495 | let mypub = toPublic $ userSecret acnt | ||
496 | me = key2id mypub | ||
497 | soliciting <- checkSoliciting (txPresence tx) mypub them contact | ||
498 | when wanted $ do | ||
499 | akey <- return $ akeyDHTKeyShare announcer me them | ||
500 | -- We send this packet every 30 seconds if there is more | ||
501 | -- than one peer (in the 8) that says they our friend is | ||
502 | -- announced on them. This packet can also be sent through | ||
503 | -- the DHT module as a DHT request packet (see DHT) if we | ||
504 | -- know the DHT public key of the friend and are looking | ||
505 | -- for them in the DHT but have not connected to them yet. | ||
506 | -- 30 second is a reasonable timeout to not flood the | ||
507 | -- network with too many packets while making sure the | ||
508 | -- other will eventually receive the packet. Since packets | ||
509 | -- are sent through every peer that knows the friend, | ||
510 | -- resending it right away without waiting has a high | ||
511 | -- likelihood of failure as the chances of packet loss | ||
512 | -- happening to all (up to to 8) packets sent is low. | ||
513 | -- | ||
514 | let meth = SearchMethod (toxQSearch tox) onResult nearNodes (key2id them) 30 | ||
515 | where | ||
516 | onResult theirkey rendezvous = do | ||
517 | dkey <- Tox.getContactInfo tox | ||
518 | let tr = Tox.toxToRoute tox | ||
519 | route = Tox.AnnouncedRendezvous theirkey rendezvous | ||
520 | dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":" | ||
521 | , "Sending my DHT-key" | ||
522 | , show (key2id $ Tox.dhtpk dkey) | ||
523 | , "to" | ||
524 | , show (key2id theirkey) | ||
525 | , "via" | ||
526 | , show (Tox.rendezvousNode rendezvous) | ||
527 | ] | ||
528 | sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey) | ||
529 | forM_ soliciting $ \cksum@(NoSpam nospam _)-> do | ||
530 | dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":" | ||
531 | , "Sending friend-request" | ||
532 | , "with nospam" | ||
533 | , "(" ++ nospam64 cksum ++ "," ++nospam16 cksum ++ ")" | ||
534 | , "to" | ||
535 | , show (key2id theirkey) | ||
536 | , "via" | ||
537 | , show (Tox.rendezvousNode rendezvous) | ||
538 | ] | ||
539 | let fr = FriendRequest | ||
540 | { friendNoSpam = nospam | ||
541 | , friendRequestText = "XMPP friend request" | ||
542 | } | ||
543 | sendMessage tr route (mypub,Tox.OnionFriendRequest fr) | ||
544 | scheduleSearch announcer akey meth them | ||
545 | |||
546 | startConnecting :: ToxToXMPP -> PublicKey -> String -> IO () | ||
547 | startConnecting tx them reason = do | ||
548 | mc <- atomically $ HashMap.lookup (key2id them) | ||
549 | <$> readTVar (contacts $ txAccount tx) | ||
550 | forM_ mc $ flip (startConnecting0 tx them) reason | ||
551 | |||
552 | |||
553 | stopConnecting :: ToxToXMPP -> PublicKey -> String -> IO () | ||
554 | stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do | ||
555 | dput XMan $ "STOP CONNECTING " ++ show (key2id them) ++ "("++reason++")" | ||
556 | let pub = toPublic $ userSecret acnt | ||
557 | me = key2id pub | ||
558 | akeyC = akeyConnect announcer me them | ||
559 | akeyD = akeyDHTKeyShare announcer me them | ||
560 | cancel announcer akeyC | ||
561 | cancel announcer akeyD | ||
562 | |||
563 | forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId | ||
564 | forkAccountWatcher acc tox st announcer = forkIO $ do | ||
565 | myThreadId >>= flip labelThread ("tox-xmpp:" | ||
566 | ++ show (key2id $ toPublic $ userSecret acc)) | ||
567 | (chan,cs) <- atomically $ do | ||
568 | chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading. | ||
569 | contacts <- readTVar (contacts acc) | ||
570 | return (chan,contacts) | ||
571 | let tx = ToxToXMPP { txAnnouncer = announcer | ||
572 | , txAccount = acc | ||
573 | , txPresence = st | ||
574 | , txTox = tox | ||
575 | } | ||
576 | forM_ (HashMap.toList cs) $ \(them,c) -> do | ||
577 | startConnecting0 tx (id2key them) c "enabled account" | ||
578 | |||
579 | -- Loop endlessly until accountExtra is null. | ||
580 | fix $ \loop -> do | ||
581 | mev <- atomically $ | ||
582 | (Just <$> readTChan chan) | ||
583 | `orElse` do | ||
584 | refs <- readTVar $ accountExtra acc | ||
585 | check $ Map.null refs | ||
586 | return Nothing | ||
587 | |||
588 | forM_ mev $ \ev -> dispatch tx ev >> loop | ||
589 | |||
590 | cs <- atomically $ readTVar (contacts acc) | ||
591 | forM_ (HashMap.toList cs) $ \(them,c) -> do | ||
592 | stopConnecting tx (id2key them) "disabled account" | ||
593 | |||
594 | |||
595 | toxQSearch :: Tox extra -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous | ||
596 | toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox) | ||
597 | |||
598 | toxAnnounceInterval :: POSIXTime | ||
599 | toxAnnounceInterval = 15 | ||
600 | |||
601 | |||
602 | |||