From ad20be57786ad34f80192206c480d575392b4ebb Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 8 Sep 2018 04:31:51 -0400 Subject: ToxManager rewrite: use aggregated netcrypto sessions. --- ToxManager.hs | 209 +++++++++++++++++++++++++++++++++++++---------------- dht-client.cabal | 2 + examples/dhtd.hs | 83 ++++++++++++++++++++- src/Network/Tox.hs | 11 +++ 4 files changed, 240 insertions(+), 65 deletions(-) diff --git a/ToxManager.hs b/ToxManager.hs index cfdb4f50..78049010 100644 --- a/ToxManager.hs +++ b/ToxManager.hs @@ -9,10 +9,10 @@ module ToxManager where import Announcer import Announcer.Tox import ClientState -import Connection import Control.Concurrent.STM import Control.Monad import Crypto.Tox +import qualified Data.ByteArray as BA import Data.Bits import Data.Function import qualified Data.HashMap.Strict as HashMap @@ -24,6 +24,8 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX import Data.Word import DPut +import Foreign.Storable +import HandshakeCache import Network.Address import qualified Network.Kademlia.Routing as R ;import Network.Kademlia.Routing as R @@ -31,9 +33,9 @@ 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 qualified Network.Tox.Crypto.Handlers as Tox - ;import Network.Tox.Crypto.Handlers (UponCookie (..)) import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest) import Network.Tox.DHT.Handlers import qualified Network.Tox.DHT.Transport as Tox @@ -53,7 +55,8 @@ import Control.Concurrent.Lifted.Instrument import Control.Concurrent.Lifted import GHC.Conc (labelThread) #endif - +import GHC.Conc (unsafeIOToSTM) +import Connection toxAnnounceSendData :: Tox.Tox JabberClients @@ -84,12 +87,13 @@ stringToKey_ s = let (xs,ys) = break (==':') s -- -- These hooks will be invoked in order to connect to *.tox hosts in a user's -- XMPP roster. -toxman :: Announcer +toxman :: TVar (Map.Map Uniq24 AggregateSession) + -> Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox JabberClients -> PresenceState -> ToxManager ClientAddress -toxman announcer toxbkts tox presence = ToxManager +toxman ssvar announcer toxbkts tox presence = ToxManager { activateAccount = \k pubname seckey -> do dput XMan $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey) let ContactInfo{ accounts } = Tox.toxContactInfo tox @@ -123,7 +127,7 @@ toxman announcer toxbkts tox presence = ToxManager toxAnnounceInterval) pub - forkAccountWatcher acnt tox presence announcer + forkAccountWatcher ssvar acnt tox presence announcer return () , deactivateAccount = \k pubname -> do @@ -168,23 +172,39 @@ toxman announcer toxbkts tox presence = ToxManager Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc -- If unscheduled and unconnected, schedule recurring search for this contact. _ -> return () -- Remove contact. - , connections = _todo + , 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 } , resolveToxPeer = \me them -> do - let lookupContact accs - = do meid <- readMaybe $ T.unpack me - themid <- readMaybe $ T.unpack them - acc <- HashMap.lookup meid accs - return $ HashMap.lookup themid <$> readTVar (contacts acc) - atomically $ do - accs <- let ContactInfo{ accounts } = Tox.toxContactInfo tox - in readTVar accounts - mc <- join <$> sequence (lookupContact accs) - maddr <- join <$> mapM (readTVar . contactLastSeenAddr) mc - return $ addrToPeerKey . Remote . Tox.nodeAddr . snd <$> maddr + let m = do meid <- readMaybe $ T.unpack me + themid <- readMaybe $ T.unpack them + return (id2key meid, id2key themid) + forM m $ \(me,them) -> do + u <- xor24 <$> hash24 me <*> hash24 them + return $ addrToPeerKey $ Remote $ uniqueAsKey u } key2jid :: Word32 -> PublicKey -> Text @@ -209,10 +229,11 @@ initPerClient = do } data ToxToXMPP = ToxToXMPP - { txAnnouncer :: Announcer - , txAccount :: Account JabberClients - , txPresence :: PresenceState - , txTox :: Tox JabberClients + { txAnnouncer :: Announcer + , txAccount :: Account JabberClients + , txPresence :: PresenceState + , txTox :: Tox JabberClients + , txSessions :: TVar (Map.Map Uniq24 AggregateSession) } default_nospam :: Word32 @@ -316,26 +337,40 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee tox :: Tox JabberClients tox = txTox tx + crypto = toxCryptoKeys tox + + {- byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) - crypto = Tox.transportCrypto $ toxCryptoSessions tox - readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr - - chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) - chillSesh = readNcVar Tox.ncState + -} activeSesh :: SockAddr -> STM Bool - activeSesh a = chillSesh a >>= return . \case - Just Established -> True - _ -> False - + activeSesh a = do + 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 + + {- readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) readCookie = readNcVar Tox.ncCookie readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie + -} client :: Network.Tox.DHT.Handlers.Client client = toxDHT tox @@ -359,7 +394,15 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee active <- isActive return $ when (not active) getCookieIO - callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) + callRealShakeHands cookie = do + {- + forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do + hs <- cacheHandshake (toxHandshakeCache tox) (userSecret (txAccount tx)) theirKey ni' cookie + dput XNetCrypto $ show addr ++ "<-- handshake " ++ show (key2id theirKey) + sendMessage (toxHandshakes tox) (nodeAddr ni) hs + -} + realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) cookie + reschedule n f = scheduleRel ann akey f n reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) @@ -368,10 +411,16 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee getCookieIO :: IO () getCookieIO = do - dput XUnused "getCookieIO - entered" + dput XNetCrypto $ show addr ++ " <-- request cookie" + let pending flag = setPendingCookie (toxHandshakeCache tox) myPublicKey theirKey flag + atomically $ pending True cookieRequest crypto client myPublicKey ni >>= \case - Nothing -> atomically $ reschedule' 5 (const getCookieAgain) + 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 ()) @@ -388,6 +437,7 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee 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" @@ -409,6 +459,8 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do -- send handshake isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr) + + dispatch :: ToxToXMPP -> ContactEvent -> IO () dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey "established" dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey "terminated" @@ -524,24 +576,20 @@ startConnecting0 tx them contact reason = do dkey <- Tox.getContactInfo tox let tr = Tox.toxToRoute tox route = Tox.AnnouncedRendezvous theirkey rendezvous - dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":" - , "Sending my DHT-key" - , show (key2id $ Tox.dhtpk dkey) - , "to" - , show (key2id theirkey) - , "via" - , show (Tox.rendezvousNode 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 mypub) ++ ":" - , "Sending friend-request" - , "with nospam" - , "(" ++ nospam64 cksum ++ "," ++nospam16 cksum ++ ")" - , "to" - , show (key2id theirkey) - , "via" - , show (Tox.rendezvousNode rendezvous) + 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 @@ -559,7 +607,7 @@ startConnecting tx them reason = do stopConnecting :: ToxToXMPP -> PublicKey -> String -> IO () stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do - dput XMan $ "STOP CONNECTING " ++ show (key2id them) ++ "("++reason++")" + dput XMan $ "STOP("++reason++") CONNECTING " ++ show (key2id them) let pub = toPublic $ userSecret acnt me = key2id pub akeyC = akeyConnect announcer me them @@ -567,18 +615,20 @@ stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do cancel announcer akeyC cancel announcer akeyD -forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId -forkAccountWatcher acc tox st announcer = forkIO $ do - myThreadId >>= flip labelThread ("tox-xmpp:" +forkAccountWatcher :: TVar (Map.Map Uniq24 AggregateSession) + -> Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId +forkAccountWatcher ssvar 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 + let tx = ToxToXMPP { txAnnouncer = announcer + , txAccount = acc + , txPresence = st + , txTox = tox + , txSessions = ssvar } forM_ (HashMap.toList cs) $ \(them,c) -> do startConnecting0 tx (id2key them) c "enabled account" @@ -597,13 +647,48 @@ forkAccountWatcher acc tox st announcer = forkIO $ do cs <- atomically $ readTVar (contacts acc) forM_ (HashMap.toList cs) $ \(them,c) -> do stopConnecting tx (id2key them) "disabled account" + -- TODO: closeAll for each relevant session in ssvar. -toxQSearch :: Tox extra -> 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 - - +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 + haveCookie <- haveCachedCookie hs me them + return $ statusLogic astat policy mdht maddr haveCookie + +statusLogic :: Status ToxProgress -> Policy -> Maybe dhtkey -> Maybe addr -> Bool -> Status ToxProgress +statusLogic astat policy mdht maddr haveCookie = case () of + () | Established <- astat -> Established + | InProgress AwaitingSessionPacket <- astat -> InProgress AwaitingSessionPacket + | RefusingToConnect <- policy -> Dormant + | Nothing <- mdht -> InProgress AwaitingDHTKey + | Nothing <- maddr -> InProgress AcquiringIPAddress + | not haveCookie -> 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 diff --git a/dht-client.cabal b/dht-client.cabal index bddb07b3..0eef7cee 100644 --- a/dht-client.cabal +++ b/dht-client.cabal @@ -146,6 +146,8 @@ library ToxManager XMPPToTox DebugUtil + HandshakeCache + Network.Tox.AggregateSession build-depends: base , containers diff --git a/examples/dhtd.hs b/examples/dhtd.hs index db8664e8..34b555f5 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -31,6 +31,7 @@ import Data.Array.MArray (getAssocs) import Data.Bool import Data.Char import Data.Conduit as C +import qualified Data.Conduit.List as C import Data.Function import Data.Hashable import Data.List @@ -105,6 +106,7 @@ import Network.Tox.ContactInfo as Tox import OnionRouter import Data.PacketQueue import qualified Data.Word64Map as W64 +import Network.Tox.AggregateSession import System.FilePath import System.Process import System.Posix.IO @@ -1622,6 +1624,71 @@ showMsg (n,(flg,(snapshot,iocm))) = B.concat [bool " " "h " flg, showmsg' (snap _ | o <= 122 && o >= 97 -> chr (o + 119737) _ -> x +onNewToxSession :: XMPPServer + -> TVar (Map.Map Uniq24 AggregateSession) + -> ContactInfo extra + -> SockAddr + -> Tox.NetCryptoSession + -> IO () +onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do + let them s = Tox.ncTheirPublicKey s + + me s = Tox.ncMyPublicKey s + + onStatusChange :: (Tox.NetCryptoSession -> Tcp.ConnectionEvent XML.Event -> STM ()) + -> AggregateSession -> Tox.NetCryptoSession -> Status Tox.ToxProgress -> STM () + onStatusChange announce c s Established = onConnect announce c s + onStatusChange announce _ s _ = onEOF announce s + + onEOF announce s = do + HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts + >>= mapM_ (setTerminated $ them s) + announce s Tcp.EOF + + onConnect announce c s = do + HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts + >>= mapM_ (setEstablished $ them s) + announce s $ Tcp.Connection (return False) xmppSrc xmppSnk + where + toxSrc :: ConduitT () (Int, CryptoMessage) IO () + toxSnk :: ConduitT (Maybe Int, CryptoMessage) Void IO () + xmppSrc :: ConduitT () XML.Event IO () + xmppSnk :: ConduitT (Flush XML.Event) Void IO () + + toxSrc = ioToSource (atomically $ orElse (awaitAny c) + $ aggregateStatus c >>= \case + Dormant -> return Nothing + _ -> retry) + (return ()) + toxSnk = C.mapM_ (uncurry $ dispatchMessage c) + xmppSrc = toxSrc .| C.map snd .| toxToXmpp addrTox (me s) (xmppHostname $ them s) + xmppSnk = flushPassThrough xmppToTox + .| C.mapMaybe (\case Flush -> Nothing + Chunk x -> Just (Nothing,x)) + .| toxSnk + + uniqkey <- xor24 <$> hash24 (them netcrypto) <*> hash24 (me netcrypto) + + c <- atomically $ do + mc <- Map.lookup uniqkey <$> readTVar ssvar + case mc of + Nothing -> do + announce <- do + v <- newTVar Nothing + let ck = uniqueAsKey uniqkey + condta s = ConnectionData (Left (Local addrTox)) + XMPPServer.Tox + (xmppHostname $ me s) + v + return $ \s e -> writeTChan (xmppEventChannel sv) ( (ck, condta s), e) + c <- newAggregateSession $ onStatusChange announce + modifyTVar' ssvar $ Map.insert uniqkey c + return c + Just c -> return c + + addSession c netcrypto + + return () main :: IO () main = do @@ -1775,7 +1842,7 @@ main = do , qshowTok = (const Nothing) }) , ("toxid", DHTQuery - { qsearch = toxQSearch tox + { qsearch = Tox.toxQSearch tox , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok) (\ni nid -> Tox.unwrapAnnounceResponse Nothing @@ -1932,6 +1999,7 @@ main = do _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs + ssvar <- atomically $ newTVar Map.empty (msv,mconns,mstate) <- case portxmpp opts of "" -> return (Nothing,Nothing,Nothing) p -> do @@ -1952,7 +2020,8 @@ main = do , lookupBkts "tox6" toxdhts ] - state <- newPresenceState cw (toxman announcer toxbkts <$> mbtox) serverVar + let tman = toxman ssvar announcer toxbkts <$> mbtox + state <- newPresenceState cw tman serverVar sv <- xmppServer Tcp.noCleanUp (presenceHooks state (verbosity opts) (Just cport) (Just sport)) -- We now have a server object but it's not ready to use until @@ -1965,6 +2034,7 @@ main = do forM_ (take 1 taddrs) $ \addrTox -> do atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do + {- -- allsessionsMap <- atomically $ readTVar (netCryptoSessions netCryptoSessionsState) let sockAddr = Tox.ncSockAddr netcrypto pubKey = Tox.ncTheirPublicKey netcrypto @@ -1975,15 +2045,21 @@ main = do onEOF = return () -- setTerminate is called elsewhere. xmppSrc = ioToSource receiveCrypto onEOF xmppSink = newXmmpSink netcrypto + -} forM_ msv $ \sv -> do let Tox.HaveDHTKey saddr = Tox.ncSockAddr netcrypto + {- Tox.HaveDHTKey dkey = Tox.ncTheirDHTKey netcrypto nid = Tox.key2id dkey them = Tox.ncTheirPublicKey netcrypto me = Tox.ncMyPublicKey netcrypto + announceToxJabberPeer me them (xmppEventChannel sv) addrTox saddr pingflag xmppSrc xmppSink + -} + forM_ mbtox $ \tox -> do - let ContactInfo{accounts} = Tox.toxContactInfo tox + onNewToxSession sv ssvar (Tox.toxContactInfo tox) saddr netcrypto + {- mbacc <- HashMap.lookup (Tox.key2id me) <$> atomically (readTVar accounts) -- TODO: Add account if it doesn't exist? @@ -1998,6 +2074,7 @@ main = do let (listenerId,supply') = freshId supply writeTVar (Tox.listenerIDSupply netCryptoSessionsState) supply' modifyTVar' (Tox.ncListeners netcrypto) (IntMap.insert listenerId (0,tmchan)) + -} return Nothing let dhts = Map.union btdhts toxdhts diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index c1cdb151..3ad2b11e 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -32,6 +32,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import Data.Data import Data.Functor.Contravariant +import Data.IP import Data.Maybe import qualified Data.MinMaxPSQ as MinMaxPSQ import qualified Data.Serialize as S @@ -50,7 +51,9 @@ import Connection import Crypto.Tox import Data.Word64Map (fitsInInt) import qualified Data.Word64Map (empty) +import HandshakeCache import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap) +import Network.Kademlia.Search import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket) import Network.Tox.Handshake import Network.Tox.Crypto.Handlers @@ -203,6 +206,7 @@ data Tox extra = Tox , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted) , toxHandshakes :: Transport String SockAddr (Handshake Encrypted) + , toxHandshakeCache :: HandshakeCache , toxCryptoSessions :: NetCryptoSessions , toxCryptoKeys :: TransportCrypto , toxRouting :: DHT.Routing @@ -442,6 +446,8 @@ newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net + hscache <- newHandshakeCache crypto (sendMessage handshakes) + let sessionsState = sessionsState0 { sendHandshake = sendMessage handshakes , sendSessionPacket = sendMessage cryptonet , transportCrypto = crypto @@ -479,6 +485,7 @@ newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do , toxToRoute = onInbound (updateContactInfo roster) dtacrypt , toxCrypto = addHandler (dput XMisc) (sessionPacketH sessionsState) cryptonet , toxHandshakes = addHandler (dput XMisc) (handshakeH sessionsState) handshakes + , toxHandshakeCache = hscache , toxCryptoSessions = sessionsState , toxCryptoKeys = crypto , toxRouting = mkrouting dhtclient @@ -550,3 +557,7 @@ announceToLan sock nid = do let broadcast = addrAddress broadcast_info bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) saferSendTo sock bs broadcast + +toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous +toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox) + -- cgit v1.2.3