{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ViewPatterns #-} module ToxManager where import Announcer import Announcer.Tox import ClientState import Codec.AsciiKey256 import ConfigFiles import Control.Arrow import Control.Concurrent.STM import Control.Monad import Crypto.Tox import Data.Bits import qualified Data.ByteArray as BA import Data.Dependent.Sum import Data.Function import qualified Data.HashMap.Strict as HashMap import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Ord import qualified Data.Set as Set import qualified Data.Text as T ;import Data.Text (Text) import Data.Time.Clock.POSIX import qualified Data.Tox.DHT.Multi as Multi import Data.Word import DPut import DebugTag import Foreign.Storable import HandshakeCache import Network.Address import Network.Kademlia.Bootstrap import qualified Network.Kademlia.Routing as R ;import Network.Kademlia.Routing as R import Network.Kademlia.Search import Network.QueryResponse import qualified Network.Tox as Tox ;import Network.Tox import Network.Tox.AggregateSession import Network.Tox.ContactInfo as Tox import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest) import Network.Tox.DHT.Handlers import qualified Network.Tox.DHT.Transport as Tox ;import Network.Tox.DHT.Transport (FriendRequest (..), dhtpk) import Network.Tox.NodeId import qualified Network.Tox.Onion.Handlers as Tox import qualified Network.Tox.Onion.Transport as Tox ;import Network.Tox.Onion.Transport (OnionData (..)) import Network.Tox.Onion.Routes (tcpKademliaClient,tcpBucketRefresher) import qualified Network.Tox.TCP as TCP import Presence import Text.Read import Util (unsplitJID) import XMPPServer as XMPP #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted import GHC.Conc (labelThread) #endif import Connection import Connection.Tcp (TCPStatus) import GHC.Conc (unsafeIOToSTM) data Pending = ToxStatus ToxProgress | XMPPStatus TCPStatus toxAnnounceSendData :: Tox.Tox JabberClients -> 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 akeyAccountActive :: Announcer -> Tox.NodeId{- our public tox key -} -> AnnounceKey akeyAccountActive announcer pubid = packAnnounceKey announcer $ "toxid:" ++ show pubid stringToKey_ :: String -> Maybe ToxContact stringToKey_ s = let (xs,ys) = break (==':') s in if null ys then Nothing else do me <- readMaybe xs them <- readMaybe (drop 1 ys) return $ ToxContact me them -- | -- -- These hooks will be invoked in order to connect to *.tox hosts in a user's -- XMPP roster. toxman :: TVar (Map.Map Uniq24 AggregateSession) -> Announcer -> Tox.Tox JabberClients -> PresenceState Pending -> ToxManager ClientAddress toxman ssvar announcer tox presence = ToxManager { activateAccount = \k pubname seckey -> do dput XMan $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey) let ContactInfo{ accounts } = Tox.toxContactInfo tox pub = toPublic seckey pubid = Tox.key2id pub (acnt,newlyActive) <- atomically $ do macnt <- HashMap.lookup pubid <$> readTVar accounts acnt <- maybe (newAccount seckey Map.empty) return macnt rs <- readTVar $ accountExtra acnt perclient <- initPerClient writeTVar (accountExtra acnt) $! Map.insert k perclient rs modifyTVar accounts (HashMap.insert pubid acnt) if not (Map.null rs) then return (acnt,Nothing) else return (acnt,Just $ \nid -> nearNodes tox nid) forM_ newlyActive $ \nearNodes -> do -- Schedule recurring announce. -- let akey = akeyAccountActive announcer pubid scheduleAnnounce announcer akey (AnnounceMethod (toxQSearch tox) (toxAnnounceSendData tox) nearNodes pubid toxAnnounceInterval) pub forkAccountWatcher ssvar (TCP.tcpClient $ tcpKademliaClient $ toxOnionRoutes tox) acnt tox presence announcer return () , deactivateAccount = \k pubname -> do dput XMan $ "toxman DEACTIVATE " ++ show pubname let ContactInfo{ accounts } = Tox.toxContactInfo tox mpubid = stripSuffix ".tox" pubname >>= readMaybe . T.unpack bStopped <- fmap (fromMaybe Nothing) $ atomically $ do forM mpubid $ \pubid -> do refs <- do macnt <- HashMap.lookup pubid <$> readTVar accounts rs <- fromMaybe Map.empty <$> mapM (readTVar . accountExtra) macnt forM_ macnt $ \acnt -> do -- Remove this xmpp client /k/ from the set holding this -- account active. modifyTVar' (accountExtra acnt) $ Map.delete k return rs return $ if (Map.null $ Map.delete k refs) then let akey = akeyAccountActive announcer pubid in Just akey else Nothing forM_ bStopped $ \akey -> do let Just pubid = mpubid pub = Tox.id2key pubid -- Stop the announce-toxid task for this account. Note that other -- announced tasks will be stopped by the forkAccountWatcher thread -- when it terminates. cancel announcer akey , toxConnections = Manager { setPolicy = \(ToxContact meid themid) p -> do dput XMan $ "toxman ConnectionPolicy " ++ show (meid,themid,p) case p of TryingToConnect -> do let db@ContactInfo{ accounts } = Tox.toxContactInfo tox sequence_ $ do Just $ atomically $ do accs <- readTVar accounts case HashMap.lookup meid accs of Nothing -> return () -- Unknown account. Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc -- If unscheduled and unconnected, schedule recurring search for this contact. _ -> return () -- Remove contact. , connections = do let ContactInfo{ accounts } = Tox.toxContactInfo tox as <- HashMap.toList <$> readTVar accounts fmap concat $ forM as $ \(me,a) -> do ks <- HashMap.keys <$> readTVar (contacts a) return $ map (ToxContact me) ks , status = \(ToxContact me them) -> do ma <- HashMap.lookup me <$> readTVar (accounts $ Tox.toxContactInfo tox) fmap (fromMaybe (Connection Dormant RefusingToConnect)) $ forM ma $ \a -> do mc <- getContact (id2key them) a let mek = id2key me themk = id2key them u <- xor24 <$> unsafeIOToSTM (hash24 mek) <*> unsafeIOToSTM (hash24 themk) ag <- do ag <- Map.lookup u <$> readTVar ssvar maybe (return Nothing) (\c -> checkCompatible mek themk c >>= \case Just False -> return Nothing _ -> return ag) ag s <- getStatus mek themk ag mc (toxHandshakeCache tox) mp <- join <$> mapM (readTVar . contactPolicy) mc return $ Connection s (fromMaybe RefusingToConnect mp) , stringToKey = stringToKey_ , showProgress = show , showKey = show , resolvePeer = \(ToxContact me them) -> do let mek = id2key me themk = id2key them u <- xor24 <$> hash24 mek <*> hash24 themk return [uniqueAsKey u] , reverseAddress = \paddr -> atomically $ do -- This will only succeed if there is an established session. -- TODO: Is that sufficient? ss <- readTVar ssvar m <- forM (keyAsUnique paddr >>= (`Map.lookup` ss)) $ \c -> do fmap (uncurry ToxContact . (key2id *** key2id)) <$> compatibleKeys c return $ maybeToList (join m) } :: Connection.Manager ToxProgress ToxContact , resolveToxPeer = \me them -> do let m = do meid <- readMaybe $ T.unpack me themid <- readMaybe $ T.unpack them return (id2key meid, id2key themid) forM m $ \(me,them) -> do u <- meAndThem me them return $ addrToPeerKey $ Remote $ peerAddress $ uniqueAsKey u } meAndThem :: PublicKey -> PublicKey -> IO Uniq24 meAndThem me them = xor24 <$> hash24 me <*> hash24 them key2jid :: Word32 -> PublicKey -> Text key2jid nospam key = T.pack $ show $ NoSpamId nsp key where nsp = NoSpam nospam (Just sum) sum = nlo `xor` nhi `xor` xorsum key nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 type JabberClients = Map.Map ClientAddress PerClient data PerClient = PerClient { pcDeliveredFRs :: TVar (Set.Set Tox.FriendRequest) } initPerClient :: STM PerClient initPerClient = do frs <- newTVar Set.empty return PerClient { pcDeliveredFRs = frs } data ToxToXMPP = ToxToXMPP { txAnnouncer :: Announcer , txAccount :: Account JabberClients , txPresence :: PresenceState Pending , txTox :: Tox JabberClients , txSessions :: TVar (Map.Map Uniq24 AggregateSession) , txTCP :: TCP.RelayClient } default_nospam :: Word32 default_nospam = 0x6a7a27fc -- big-endian base64: anon/A== nodeinfoStaleTime :: POSIXTime nodeinfoStaleTime = 600 -- consider DHT node address stale after 10 minutes nodeinfoSearchInterval :: POSIXTime nodeinfoSearchInterval = 15 -- when no address, search DHT node every 15 seconds cycled :: [x] -> [x] cycled [] = [] cycled (x:xs) = xs ++ [x] -- Notes: -- send cookieRequest OOB -- request relay session -- send handshake OOB connectViaRelay :: ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> Announcer -> AnnounceKey -> POSIXTime -> STM (IO ()) connectViaRelay tx theirKey theirDhtKey ann tkey now = do mcontact <- getContact theirKey (txAccount tx) case mcontact of Nothing -> return $ return () Just contact -> do established <- activeSesh tx theirKey return $ when (not established) go where myPublicKey = toPublic $ userSecret (txAccount tx) me = key2id myPublicKey tkey = akeyConnectTCP (txAnnouncer tx) me theirKey go = do let Tox.SendNodes ns = Tox.dhtpkNodes theirDhtKey mcons <- forM ns $ \ni -> do mcon <- Multi.tcpConnectionRequest (txTCP tx) (Tox.dhtpk theirDhtKey) ni return mcon let oobs = [ Multi.TCP ==> TCP.ViaRelay Nothing (Tox.key2id $ Tox.dhtpk theirDhtKey) ni | ni <- ns ] forM_ (catMaybes mcons ++ oobs) $ \ni -> do cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case Nothing -> return () Just cookie -> do cookieCreationStamp <- getPOSIXTime let their_nid = key2id $ dhtpk theirDhtKey dput XNetCrypto $ show their_nid ++ " --> cookie (TCP)" hs <- cacheHandshake (toxHandshakeCache $ txTox tx) (userSecret (txAccount tx)) theirKey ni cookie dput XNetCrypto $ show their_nid ++ "<-- handshake " ++ show (key2id theirKey) ++ " (TCP)" sendMessage (toxHandshakes $ txTox tx) (Multi.sessionAddr ni) hs atomically $ do -- Try again in 5 seconds. let theirDhtKey' = theirDhtKey' { Tox.dhtpkNodes = Tox.SendNodes (cycled ns) } scheduleRel ann tkey (ScheduledItem $ connectViaRelay tx theirKey theirDhtKey') 5 gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () gotDhtPubkey theirDhtKey tx theirKey = do dput XNetCrypto $ unlines $ [ "Recieved DHTKey from " ++ show (Tox.key2id theirKey) , " DHT: " ++ show target ] ++ let Tox.SendNodes ns = Tox.dhtpkNodes theirDhtKey in [ " relay " ++ show n | n <- ns ] contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr) forM_ contact $ \lastSeen -> do case lastSeen of Nothing -> doSearch Just (tm, _) -> do now <- getPOSIXTime when (now - tm > nodeinfoStaleTime) doSearch where tox :: Tox JabberClients tox = txTox tx myPublicKey = toPublic $ userSecret (txAccount tx) me = key2id myPublicKey doSearch = do let akey = akeyConnect (txAnnouncer tx) me theirKey tkey = akeyConnectTCP (txAnnouncer tx) me theirKey atomically $ registerNodeCallback (toxRouting tox) (nic akey) scheduleSearch (txAnnouncer tx) akey meth theirDhtKey atomically $ scheduleImmediately (txAnnouncer tx) tkey $ ScheduledItem $ connectViaRelay tx theirKey theirDhtKey target :: NodeId target = key2id $ dhtpk theirDhtKey meth :: SearchMethod Tox.DHTPublicKey meth = SearchMethod { sSearch = nodeSearch (toxDHT tox) (nodesOfInterest $ toxRouting tox) , sNearestNodes = nearNodes tox , sTarget = target , sInterval = nodeinfoSearchInterval , sWithResult = \r sr -> return () } nic akey = NodeInfoCallback { interestingNodeId = target , listenerId = 2 , observedAddress = observe akey , rumoredAddress = assume akey } showak :: AnnounceKey -> String showak k = unpackAnnounceKey (txAnnouncer tx) k assume :: Show infosource => AnnounceKey -> POSIXTime -> infosource -> NodeInfo -> STM () assume akey time addr ni = tput XNodeinfoSearch $ show ("rumor", showak akey, time, addr, ni) observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () observe akey time ni@(nodeAddr -> addr) = do tput XNodeinfoSearch $ show ("observation", showak akey, time, addr) setContactAddr time theirKey ni (txAccount tx) gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO () gotAddr ni@(nodeAddr -> addr) tx theirKey = do dhtkey <- (fmap.fmap) snd $ fmap join $ atomically $ traverse readTVar =<< fmap contactKeyPacket <$> getContact theirKey (txAccount tx) forM_ dhtkey $ gotAddr' ni tx theirKey gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO () gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee where myPublicKey = toPublic $ userSecret (txAccount tx) me = key2id myPublicKey akey = akeyConnect (txAnnouncer tx) me theirKey blee = do scheduleImmediately (txAnnouncer tx) akey $ ScheduledItem $ getCookie tx theirKey theirDhtKey ni (activeSesh tx theirKey) (getContact theirKey $ txAccount tx) activeSesh :: ToxToXMPP -> PublicKey -> STM Bool activeSesh tx theirKey = do let myPublicKey = toPublic $ userSecret (txAccount tx) ss <- readTVar (txSessions tx) u <- xor24 <$> unsafeIOToSTM (hash24 myPublicKey) <*> unsafeIOToSTM (hash24 theirKey) case Map.lookup u ss of Nothing -> return False -- TODO: Currently we consider the session active if it is actually established. -- Perhaps it would be better to also consider it "active" when an incompatible -- session is holding the Uniq24 slot in txSessions because the connection will -- ultimately fail anyway in that case. Alternatively, we could drop the Uniq24 -- map and use a full (PublicKey,PublicKey) key, but this would require changing -- how XMPP connections are handled since they are currently distinguished by a -- SockAddr which cannot hold more than a 24-byte key. (See XMPPServer.peerKey). Just c -> checkCompatible myPublicKey theirKey c >>= \case Just False -> return False _ -> (== Established) <$> aggregateStatus c cookieMaxAge :: POSIXTime cookieMaxAge = 60 * 5 getCookie :: ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> NodeInfo -> STM Bool -> STM (Maybe Contact) -> Announcer -> AnnounceKey -> POSIXTime -> STM (IO ()) getCookie tx theirKey theirDhtKey ni isActive getC ann akey now = getCookieAgain where myPublicKey = toPublic $ userSecret (txAccount tx) addr = nodeAddr ni hscache = toxHandshakeCache $ txTox tx getCookieAgain = do tput XNodeinfoSearch $ show ("getCookieAgain", unpackAnnounceKey ann akey) mbContact <- getC case mbContact of Nothing -> return $ return () Just contact -> do active <- isActive return $ when (not active) getCookieIO callRealShakeHands cookie = do forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do hs <- cacheHandshake hscache (userSecret (txAccount tx)) theirKey (Multi.UDP ==> ni') cookie dput XNetCrypto $ show addr ++ "<-- handshake " ++ show (key2id theirKey) sendMessage (toxHandshakes $ txTox tx) (Multi.SessionUDP ==> nodeAddr ni) hs reschedule n f = scheduleRel ann akey f n reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) getCookieIO :: IO () getCookieIO = do dput XNetCrypto $ show addr ++ " <-- request cookie" let pending flag = setPendingCookie hscache myPublicKey theirKey flag atomically $ pending True cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey (Multi.UDP ==> ni) >>= \case Nothing -> atomically $ do pending False reschedule' 5 (const getCookieAgain) Just cookie -> do dput XNetCrypto $ show addr ++ "--> cookie" atomically $ pending False void $ callRealShakeHands cookie cookieCreationStamp <- getPOSIXTime let shaker :: POSIXTime -> STM (IO ()) shaker now = do active <- isActive if (active) then return $ return () else if (now > cookieCreationStamp + cookieMaxAge) then return $ dput XNetCrypto "getCookieIO/shaker - cookie expired" >> getCookieIO else do reschedule' 5 shaker return . void $ callRealShakeHands cookie atomically $ reschedule' 5 shaker {- realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do dput XUnused "realShakeHands" let hp = HParam { hpOtherCookie = cookie , hpMySecretKey = myseckey , hpCookieRemotePubkey = theirpubkey , hpCookieRemoteDhtkey = theirDhtKey , hpTheirBaseNonce = Nothing , hpTheirSessionKeyPublic = Nothing } newsession <- generateSecretKey timestamp <- getPOSIXTime (myhandshake, ioAction) <- atomically $ Tox.freshCryptoSession allsessions saddr newsession timestamp hp ioAction -- send handshake isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr) -} dispatch :: ToxToXMPP -> ContactEvent -> IO () dispatch tx (SessionEstablished theirKey ) = do stopConnecting tx theirKey "established" updateRoster tx theirKey dispatch tx (SessionTerminated theirKey ) = startConnecting tx theirKey "terminated" dispatch tx (AddrChange theirKey saddr ) = gotAddr saddr tx theirKey dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey "policy" dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey "policy" dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey dispatch tx (OnionRouted theirkey (OnionFriendRequest fr) ) = do let ToxToXMPP { txAnnouncer = acr , txAccount = acnt , txPresence = st } = tx k2c <- atomically $ do refs <- readTVar (accountExtra acnt) k2c <- Map.intersectionWith (,) refs <$> readTVar (ckeyToChan st) clients <- readTVar (clients st) return $ Map.intersectionWith (,) k2c clients -- TODO: Below we're using a hard coded default as their jabber user id. -- This isn't the right thing, but we don't know their user-id. Perhaps -- there should be a way to parse it out of the friend request text. Maybe -- after a zero-termination, or as visible text (nospam:...). let theirjid = key2jid default_nospam theirkey forM_ k2c $ \((PerClient{pcDeliveredFRs},conn),client) -> do alreadyDelivered <- atomically $ do frs <- readTVar pcDeliveredFRs writeTVar pcDeliveredFRs $ Set.insert fr frs return $ Set.member fr frs when (not alreadyDelivered) $ do self <- localJID (clientUser client) (clientProfile client) (clientResource client) ask <- presenceSolicitation theirjid self -- TODO Send friend-request text as an instant message or at least -- embed it in the stanza as a element. sendModifiedStanzaToClient ask (connChan conn) interweave :: [a] -> [a] -> [a] interweave [] ys = ys interweave (x:xs) ys = x : interweave ys xs akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey akeyDHTKeyShare announcer me them = packAnnounceKey announcer $ "dhtkey(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey akeyConnect announcer me them = packAnnounceKey announcer $ "connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) akeyConnectTCP :: Announcer -> NodeId -> PublicKey -> AnnounceKey akeyConnectTCP announcer me them = packAnnounceKey announcer $ "tcp-connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) -- | Because Tox does not have a friend-request response, we consider an -- established connection to be an implicit two-way subscription. updateRoster :: ToxToXMPP -> PublicKey -> IO () updateRoster tx them = do let me = toPublic $ userSecret $ txAccount tx profile = T.pack $ show (key2id me) ++ ".tox" jid = T.pack $ show (key2id them) ++ ".tox" man = manager (txPresence tx) profile addr <- do u <- xor24 <$> hash24 me <*> hash24 them return [ addrToPeerKey . Remote . peerAddress . uniqueAsKey $ u ] mp <- atomically $ Map.lookup profile <$> readTVar (clientsByProfile $ txPresence tx) forM_ mp $ \LocalPresence{networkClients} -> do let css = groupBy ((==) `on` clientUser) -- We treat all clients from a single user as one. $ sortBy (comparing clientUser) $ Map.elems networkClients forM_ css $ \(c:_) -> do let user = clientUser c addToRosterFile man modifyBuddies user profile jid addr addToRosterFile man modifySubscribers user profile jid addr -- Cancel friend-request sending. modifyRosterFile man modifySolicited user profile jid addr False True -- | Returns a list of nospam values to use for friend requests to send to a -- remote peer. This list is non-empty only when it is desirable to send -- friend requests. checkSoliciting :: PresenceState Pending -> PublicKey -> PublicKey -> Contact -> IO [NoSpam] checkSoliciting presence me them contact = do let theirhost = T.pack $ show (key2id them) ++ ".tox" myhost = T.pack $ show (key2id me) ++ ".tox" xs <- getBuddiesAndSolicited presence myhost $ \h -> do return $ T.toLower h == T.toLower theirhost return $ do (is_buddy,their_u,my_uid,xmpp_client_profile) <- xs guard $ xmpp_client_profile == myhost NoSpamId nospam _ <- case fmap T.unpack $ their_u of Just ('$':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing) Just ('0':'x':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing) _ -> maybeToList $ readMaybe $ T.unpack $ key2jid default_nospam them return nospam nearNodes :: Tox extra -> NodeId -> STM [NodeInfo] nearNodes tox nid = do let refresher = tcpBucketRefresher $ toxOnionRoutes tox bkts4 <- readTVar $ routing4 $ toxRouting tox bkts6 <- readTVar $ routing6 $ toxRouting tox bktsTCP <- readTVar $ refreshBuckets refresher let udpSpace = searchSpace $ toxQSearch tox k = searchK $ toxQSearch tox nss = map (R.kclosest udpSpace k nid) [bkts4, bkts6] ns_UDP = foldr interweave [] nss ns_TCP = case refresher of BucketRefresher{refreshSearch=sch} -> R.kclosest (searchSpace sch) k nid bktsTCP return $ ns_UDP ++ map TCP.udpNodeInfo ns_TCP startConnecting0 :: ToxToXMPP -> PublicKey -> Contact -> String -> IO () startConnecting0 tx them contact reason = do dput XMan $ "START CONNECTING " ++ show (key2id them) ++ "("++reason++")" -- TODO When a connection is already established, this function should -- be a no-op. This occurs when an XMPP client disconnects and -- reconnects while a session is established. let ToxToXMPP { txTox = tox , txAnnouncer = announcer , txAccount = acnt } = tx wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact) let mypub = toPublic $ userSecret acnt me = key2id mypub soliciting <- checkSoliciting (txPresence tx) mypub them contact when wanted $ do akey <- return $ akeyDHTKeyShare announcer me them -- We send this packet every 30 seconds if there is more -- than one peer (in the 8) that says they our friend is -- announced on them. This packet can also be sent through -- the DHT module as a DHT request packet (see DHT) if we -- know the DHT public key of the friend and are looking -- for them in the DHT but have not connected to them yet. -- 30 second is a reasonable timeout to not flood the -- network with too many packets while making sure the -- other will eventually receive the packet. Since packets -- are sent through every peer that knows the friend, -- resending it right away without waiting has a high -- likelihood of failure as the chances of packet loss -- happening to all (up to to 8) packets sent is low. -- let meth = SearchMethod (toxQSearch tox) onResult (nearNodes tox) (key2id them) 30 where onResult theirkey rendezvous = do dkey <- Tox.getContactInfo tox let tr = Tox.toxToRoute tox route = Tox.AnnouncedRendezvous theirkey rendezvous dput XMan $ unwords [ take 8 (show $ key2id theirkey) , show (nodeAddr $ Tox.rendezvousNode rendezvous) , "<--" , "DHTKey" , take 8 (show $ key2id mypub) ++ "/" ++ take 8 (show $ key2id $ Tox.dhtpk dkey) ] sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey) forM_ soliciting $ \cksum@(NoSpam nospam _)-> do dput XMan $ unwords [ take 8 (show $ key2id theirkey) , show (nodeAddr $ Tox.rendezvousNode rendezvous) , "<-- FriendRequest" , take 8 (show $ key2id mypub) , "nospam=" ++ "(" ++ nospam64 cksum ++ "," ++nospam16 cksum ++ ")" ] let fr = FriendRequest { friendNoSpam = nospam , friendRequestText = "XMPP friend request" } sendMessage tr route (mypub,Tox.OnionFriendRequest fr) -- Seearch for friend's tox-id rendezvous and use the results to -- send our dht key. scheduleSearch announcer akey meth them startConnecting :: ToxToXMPP -> PublicKey -> String -> IO () startConnecting tx them reason = do mc <- atomically $ HashMap.lookup (key2id them) <$> readTVar (contacts $ txAccount tx) forM_ mc $ flip (startConnecting0 tx them) reason stopConnecting :: ToxToXMPP -> PublicKey -> String -> IO () stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do dput XMan $ "STOP("++reason++") CONNECTING " ++ show (key2id them) let pub = toPublic $ userSecret acnt me = key2id pub akeyC = akeyConnect announcer me them akeyD = akeyDHTKeyShare announcer me them cancel announcer akeyC cancel announcer akeyD closeSessions :: NodeId{-me-} -> NodeId{-them-} -> TVar (Map.Map Uniq24 AggregateSession) -> IO () closeSessions me them ssvar = do m <- atomically $ readTVar ssvar u <- meAndThem (id2key me) (id2key them) forM_ (Map.lookup u m) $ \ag -> do -- Just True <- checkCompatible ag (id2key me) (id2key them) closeAll ag forkAccountWatcher :: TVar (Map.Map Uniq24 AggregateSession) -> TCP.RelayClient -> Account JabberClients -> Tox JabberClients -> PresenceState Pending -> Announcer -> IO ThreadId forkAccountWatcher ssvar tcp acc tox st announcer = forkIO $ do myThreadId >>= flip labelThread ("online:" ++ show (key2id $ toPublic $ userSecret acc)) (chan,cs) <- atomically $ do chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading. contacts <- readTVar (contacts acc) return (chan,contacts) let tx = ToxToXMPP { txAnnouncer = announcer , txAccount = acc , txPresence = st , txTox = tox , txSessions = ssvar , txTCP = tcp } forM_ (HashMap.toList cs) $ \(them,c) -> do startConnecting0 tx (id2key them) c "enabled account" -- Loop endlessly until accountExtra is null. fix $ \loop -> do mev <- atomically $ (Just <$> readTChan chan) `orElse` do refs <- readTVar $ accountExtra acc check $ Map.null refs return Nothing forM_ mev $ \ev -> dispatch tx ev >> loop -- Stop tasks associated with each contact for this account. cs <- atomically $ readTVar (contacts acc) let me = key2id $ toPublic $ userSecret acc forM_ (HashMap.toList cs) $ \(them,c) -> do stopConnecting tx (id2key them) "disabled account" closeSessions me them ssvar toxAnnounceInterval :: POSIXTime toxAnnounceInterval = 15 getStatus :: PublicKey -> PublicKey -> Maybe AggregateSession -> Maybe Contact -> HandshakeCache -> STM (Status ToxProgress) getStatus me them a c hs = do astat <- maybe (return Dormant) aggregateStatus a policy <- fromMaybe RefusingToConnect <$> maybe (return Nothing) (readTVar . contactPolicy) c mdht <- maybe (return Nothing) (readTVar . contactKeyPacket) c maddr <- maybe (return Nothing) (readTVar . contactLastSeenAddr) c cookieIsPending <- getPendingCookieFlag hs me them return $ statusLogic astat policy mdht maddr cookieIsPending -- TODO: recognize TCP status statusLogic :: Status ToxProgress -> Policy -> Maybe dhtkey -> Maybe addr -> Bool -> Status ToxProgress statusLogic astat policy mdht maddr cookieIsPending = case () of () | Established <- astat -> Established | InProgress AwaitingSessionPacket <- astat -> InProgress AwaitingSessionPacket | RefusingToConnect <- policy -> Dormant | Nothing <- mdht -> InProgress AwaitingDHTKey | Nothing <- maddr -> InProgress AcquiringIPAddress | cookieIsPending -> InProgress AcquiringCookie | otherwise -> InProgress AwaitingHandshake hash24 :: BA.ByteArrayAccess ba => ba -> IO Uniq24 hash24 them | let r = 32 - BA.length them, (r > 0) = hash24 $ BA.append (BA.convert them :: BA.Bytes) (BA.replicate r 0) -- XXX: It'd be better to insert ahead of last 8 bytes. hash24 them = BA.withByteArray them $ \p -> do x <- peek p y <- peekElemOff p 1 -- skipping word64 2 z <- peekElemOff p 3 return $! Uniq24 x y z xor24 :: Uniq24 -> Uniq24 -> Uniq24 xor24 (Uniq24 xa xb xc) (Uniq24 ya yb yc) = Uniq24 (xor xa ya) (xor xb yb) (xor xc yc) -- 321 -- 357