ToxManager rewrite: use aggregated netcrypto sessions.

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)
+