8 files changed, 248 insertions, 82 deletions

diff --git a/src/Data/Word64Map.hs b/src/Data/Word64Map.hs
new file mode 100644
index 00000000..9e93c8c8
--- /dev/null
+++ b/src/Data/Word64Map.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+module Data.Word64Map where
+
+import Data.Bits
+import qualified Data.IntMap as IntMap
+         ;import Data.IntMap (IntMap)
+import Data.Typeable
+import Data.Word
+
+-- | Since 'Int' may be 32 or 64 bits, this function is provided as a
+-- convenience to test if an integral type, such as 'Data.Word.Word64', can be
+-- safely transformed into an 'Int' for use with 'IntMap'.
+--
+-- Returns 'True' if the proxied type can be losslessly converted to 'Int' using
+-- 'fromIntegral'.
+fitsInInt :: forall proxy word. (Bounded word, Integral word) => proxy word -> Bool
+fitsInInt proxy = (original == casted)
+ where
+    original = div maxBound 2 :: word
+    casted   = fromIntegral (fromIntegral original :: Int) :: word
+
+newtype Word64Map a = Word64Map (IntMap (IntMap a))
+
+empty :: Word64Map a
+empty = Word64Map IntMap.empty
+
+-- Warning: This function assumes an 'Int' is either 64 or 32 bits.
+keyFrom64 :: Word64 -> (# Int,Int #)
+keyFrom64 w8 =
+    if fitsInInt (Proxy :: Proxy Word64)
+        then (# fromIntegral w8              , 0               #)
+        else (# fromIntegral (w8 `shiftR` 32), fromIntegral w8 #)
+{-# INLINE keyFrom64 #-}
+
+lookup :: Word64 -> Word64Map b -> Maybe b
+lookup w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 = do
+    m' <- IntMap.lookup hi m
+    IntMap.lookup lo m'
+{-# INLINE lookup #-}
+
+insert :: Word64 -> b -> Word64Map b -> Word64Map b
+insert w8 b (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
+    = Word64Map $ IntMap.alter (Just . maybe (IntMap.singleton lo b)
+                                             (IntMap.insert lo b))
+                               hi
+                               m
+{-# INLINE insert #-}
+
+delete :: Word64 -> Word64Map b -> Word64Map b
+delete w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
+    = Word64Map $ IntMap.alter (maybe Nothing
+                                      (\m' -> case IntMap.delete lo m' of
+                                                m'' | IntMap.null m'' -> Nothing
+                                                m''                   -> Just m''))
+                               hi
+                               m
+{-# INLINE delete #-}
+
+
+
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index 4566471a..f4ce4019 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -584,7 +584,7 @@ newClient swarms addr = do
         gen cnt = (TransactionId $ S.encode cnt, cnt+1)
 
         client = Client
-            { clientNet           = addHandler (handleMessage client) net
+            { clientNet           = addHandler ignoreErrors (handleMessage client) net
             , clientDispatcher    = dispatch
             , clientErrorReporter = ignoreErrors -- printErrors stderr
             , clientPending       = map_var
@@ -1002,7 +1002,7 @@ mainlineSend meth unwrap msg client nid addr = do
     return $ join $ either (const Nothing) Just <$> reply
  where
     serializer = MethodSerializer
-        { methodTimeout  = 5
+        { methodTimeout  = \_ ni -> return (ni, 5000000)
         , method         = meth
         , wrapQuery      = encodeQueryPayload meth (isReadonlyClient client)
         , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack)
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 0fa1a05a..70d981e2 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -108,18 +108,18 @@ partitionTransportM parse encodex tr = do
                 }
     return (xtr, ytr)
 
-addHandler :: (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x
-addHandler f tr = tr
+addHandler :: ErrorReporter addr x meth tid err -> (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x
+addHandler err f tr = tr
     { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \m -> do
         case m of
             Just (Right (x, addr)) -> f addr x >>= maybe eat (kont . Just . Right . (, addr) . ($ x))
-            Just (Left  e        ) -> kont $ Just (Left e)
+            Just (Left  e        ) -> reportParseError err e >> kont (Just $ Left e)
             Nothing                -> kont $ Nothing
     }
 
 -- | Modify a 'Transport' to invoke an action upon every received packet.
 onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x
-onInbound f tr = addHandler (\addr x -> f addr x >> return (Just id)) tr
+onInbound f tr = addHandler ignoreErrors (\addr x -> f addr x >> return (Just id)) tr
 
 -- * Using a query\/response client.
 
@@ -153,16 +153,17 @@ sendQuery ::
         -> a                                    -- ^ The outbound query.
         -> addr                                 -- ^ Destination address of query.
         -> IO (Maybe b)                         -- ^ The response, or 'Nothing' if it timed out.
-sendQuery (Client net d err pending whoami _) meth q addr = do
+sendQuery (Client net d err pending whoami _) meth q addr0 = do
     mvar <- newEmptyMVar
-    tid <- atomically $ do
+    (tid,addr,expiry) <- atomically $ do
         tbl <- readTVar pending
-        (tid, tbl') <- dispatchRegister (tableMethods d) mvar tbl
+        (tid, tbl') <- dispatchRegister (tableMethods d) mvar addr0 tbl
+        (addr,expiry) <- methodTimeout meth tid addr0
         writeTVar pending tbl'
-        return tid
+        return (tid,addr,expiry)
     self <- whoami (Just addr)
     sendMessage net addr (wrapQuery meth tid self addr q)
-    mres <- timeout (1000000 * methodTimeout meth) $ takeMVar mvar
+    mres <- timeout expiry $ takeMVar mvar
     case mres of
         Just x -> return $ Just $ unwrapResponse meth x
         Nothing -> do
@@ -248,8 +249,10 @@ dispatchQuery (NoReply unwrapQ f) tid self x addr =
 -- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that
 -- might be returned by 'lookupHandler'.
 data MethodSerializer tid addr x meth a b = MethodSerializer
-    { -- | Seconds to wait for a response.
-      methodTimeout :: Int
+    { -- | Returns the microseconds to wait for a response to this query being
+      -- sent to the given address.  The /addr/ may also be modified to add
+      -- routing information.
+      methodTimeout :: tid -> addr -> STM (addr,Int)
       -- | A method identifier used for error reporting.  This needn't be the
       -- same as the /meth/ argument to 'MethodHandler', but it is suggested.
     , method :: meth
@@ -269,13 +272,13 @@ data MethodSerializer tid addr x meth a b = MethodSerializer
 --
 -- The type variable /d/ is used to represent the current state of the
 -- transaction generator and the table of pending transactions.
-data TransactionMethods d tid x = TransactionMethods
+data TransactionMethods d tid addr x = TransactionMethods
     {
       -- | Before a query is sent, this function stores an 'MVar' to which the
       -- response will be written too.  The returned /tid/ is a transaction id
       -- that can be used to forget the 'MVar' if the remote peer is not
       -- responding.
-      dispatchRegister :: MVar x -> d -> STM (tid, d)
+      dispatchRegister :: MVar x -> addr -> d -> STM (tid, d)
       -- | This method is invoked when an incoming packet /x/ indicates it is
       -- a response to the transaction with id /tid/.  The returned IO action
       -- is will write the packet to the correct 'MVar' thus completing the
@@ -318,27 +321,15 @@ instance Contravariant (TableMethods t) where
                      (\k t   -> del (f k) t)
                      (\k t   -> lookup (f k) t)
 
--- | Since 'Int' may be 32 or 64 bits, this function is provided as a
--- convenience to test if an integral type, such as 'Data.Word.Word64', can be
--- safely transformed into an 'Int' for use with 'IntMap'.
---
--- Returns 'True' if the proxied type can be losslessly converted to 'Int' using
--- 'fromIntegral'.
-fitsInInt :: forall word. (Bounded word, Integral word) => Proxy word -> Bool
-fitsInInt Proxy = (original == casted)
- where
-    original = div maxBound 2 :: word
-    casted   = fromIntegral (fromIntegral original :: Int) :: word
-
 -- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a
 -- function for generating unique transaction ids.
 transactionMethods ::
     TableMethods t tid  -- ^ Table methods to lookup values by /tid/.
     -> (g -> (tid,g))   -- ^ Generate a new unique /tid/ value and update the generator state /g/.
-    -> TransactionMethods (g,t (MVar x)) tid x
+    -> TransactionMethods (g,t (MVar x)) tid addr x
 transactionMethods (TableMethods insert delete lookup) generate = TransactionMethods
     { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
-    , dispatchRegister = \v (g,t) ->
+    , dispatchRegister = \v _ (g,t) ->
         let (tid,g') = generate g
             t' = insert tid v t
         in return ( tid, (g',t') )
@@ -356,7 +347,7 @@ data DispatchMethods tbl err meth tid addr x = DispatchMethods
       -- | Lookup the handler for a inbound query.
     , lookupHandler :: meth -> Maybe (MethodHandler err tid addr x)
       -- | Methods for handling incoming responses.
-    , tableMethods :: TransactionMethods tbl tid x
+    , tableMethods :: TransactionMethods tbl tid addr x
     }
 
 -- | These methods indicate what should be done upon various conditions.  Write
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 7814046e..3860d309 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -21,6 +21,7 @@ import Control.Arrow
 import Control.Concurrent                     (MVar)
 import Control.Concurrent.STM
 import Control.Monad
+import Control.Monad.Fix
 import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
 import qualified Crypto.Cipher.Salsa          as Salsa
 import qualified Crypto.Cipher.XSalsa         as XSalsa
@@ -94,6 +95,7 @@ import qualified Network.Tox.Onion.Handlers as Onion
 import Network.Tox.Crypto.Transport (NetCrypto)
 import Text.XXD
 import OnionRouter
+import Data.Word64Map (fitsInInt)
 
 newCrypto :: IO TransportCrypto
 newCrypto = do
@@ -158,7 +160,7 @@ newClient :: (DRG g, Show addr, Show meth) =>
                 -> (x -> MessageClass String meth DHT.TransactionId)
                 -> (Maybe addr -> IO addr)
                 -> (meth -> Maybe (MethodHandler String DHT.TransactionId addr x))
-                -> (forall d. TransactionMethods d DHT.TransactionId x -> TransactionMethods d DHT.TransactionId x)
+                -> (forall d. TransactionMethods d DHT.TransactionId addr x -> TransactionMethods d DHT.TransactionId addr x)
                 -> (Client String meth DHT.TransactionId addr x -> Transport String addr x -> Transport String addr x)
                 -> IO (Client String meth DHT.TransactionId addr x)
 newClient drg net classify selfAddr handlers modifytbl modifynet = do
@@ -180,11 +182,12 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
                 , lookupHandler = handlers -- var
                 , tableMethods = modifytbl tbl
                 }
+        eprinter = printErrors stderr
         mkclient (tbl,var) handlers =
             let client = Client
-                    { clientNet           = addHandler (handleMessage client) $ modifynet client net
+                    { clientNet           = addHandler eprinter (handleMessage client) $ modifynet client net
                     , clientDispatcher    = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
-                    , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors }
+                    , clientErrorReporter = eprinter { reportTimeout = reportTimeout ignoreErrors }
                     , clientPending       = var
                     , clientAddress       = selfAddr
                     , clientResponseId    = genNonce24 var
@@ -199,18 +202,22 @@ data Tox = Tox
     , toxRouting :: DHT.Routing
     , toxTokens :: TVar SessionTokens
     , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
+    , toxOnionRoutes :: OnionRouter
     }
 
-addVerbosity :: Show addr => Transport err addr ByteString -> Transport err addr ByteString
+isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
+isLocalHost _                       = False
+
+addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
 addVerbosity tr =
     tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
             forM_ m $ mapM_ $ \(msg,addr) -> do
-                when (not (B.null msg || elem (B.head msg) [0,1,2,4])) $ do
+                when (isLocalHost addr || not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
                     mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " --> " ++ x))
                           $ xxd 0 msg
             kont m
        , sendMessage = \addr msg -> do
-            when (not (B.null msg || elem (B.head msg) [0,1,2,4])) $ do
+            when (isLocalHost addr || not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
                 mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " <-- " ++ x))
                       $ xxd 0 msg
             sendMessage tr addr msg
@@ -226,13 +233,15 @@ newTox keydb addr = do
     crypto <- newCrypto
     drg <- drgNew
     let lookupClose _ = return Nothing
-    routing <- DHT.newRouting addr crypto updateIP updateIP
-
-    (dhtcrypt,onioncrypt,cryptonet) <- toxTransport crypto (DHT.orouter routing) lookupClose udp
 
+    routing <- DHT.newRouting addr crypto updateIP updateIP
+    orouter <- newOnionRouter
+    (dhtcrypt,onioncrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp
     let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
     dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers routing) id
-                    $ \client net -> onInbound (DHT.updateRouting client routing) net
+                    $ \client net -> onInbound (DHT.updateRouting client routing orouter) net
+
+    orouter <- forkRouteBuilder orouter $ \nid ni -> maybe [] (\(_,ns,_)->ns) <$> DHT.getNodes dhtclient nid ni
 
     toks <- do
         nil <- nullSessionTokens
@@ -240,13 +249,14 @@ newTox keydb addr = do
     oniondrg <- drgNew
     let onionnet = layerTransport (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
     onionclient <- newClient oniondrg onionnet Onion.classify
-                    (const $ return
-                           $ either (const $ error "bad sockaddr")
-                                    (flip Onion.OnionDestination Nothing)
-                           $ nodeInfo zeroID addr)
+                    (const $ atomically
+                           $ flip Onion.OnionDestination Nothing
+                           . R.thisNode
+                           <$> readTVar (DHT.routing4 routing))
                     (Onion.handlers onionnet routing toks keydb)
-                    (hookQueries (DHT.orouter routing) DHT.transactionKey)
+                    (hookQueries orouter DHT.transactionKey)
                     (const id)
+
     return Tox
         { toxDHT = dhtclient
         , toxOnion = onionclient
@@ -254,8 +264,12 @@ newTox keydb addr = do
         , toxRouting = routing
         , toxTokens = toks
         , toxAnnouncedKeys = keydb
+        , toxOnionRoutes = orouter
         }
 
+onionTimeout :: Tox -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
+onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od
+
 forkTox :: Tox -> IO (IO ())
 forkTox tox = do
     _ <- forkListener "toxCrypto" (toxCrypto tox)
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index c9adc860..a3f13ac7 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -105,7 +105,6 @@ data Routing = Routing
     , sched6      :: !( TVar (Int.PSQ POSIXTime) )
     , routing6    :: !( TVar (R.BucketList NodeInfo) )
     , committee6  :: TriadCommittee NodeId SockAddr
-    , orouter     :: OnionRouter
     }
 
 newRouting :: SockAddr -> TransportCrypto
@@ -124,8 +123,9 @@ newRouting addr crypto update4 update6 = do
     tentative_info6 <-
         maybe (tentative_info { nodeIP = tentative_ip6 })
               (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
-            <$> global6
-    orouter <- newOnionRouter
+            <$> case addr of
+                    SockAddrInet {} -> return Nothing
+                    _               -> global6
     atomically $ do
         let nobkts = R.defaultBucketCount :: Int
         tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts
@@ -134,7 +134,7 @@ newRouting addr crypto update4 update6 = do
         committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
         sched4 <- newTVar Int.empty
         sched6 <- newTVar Int.empty
-        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6 orouter
+        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
 
 
 -- TODO: This should cover more cases
@@ -200,7 +200,7 @@ serializer :: PacketKind
                 -> (Message -> Maybe (Assym (Nonce8,pong)))
                 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
 serializer pktkind mkping mkpong = MethodSerializer
-        { methodTimeout  = 5
+        { methodTimeout  = \tid addr -> return (addr, 5000000)
         , method         = pktkind
         -- wrapQuery :: tid -> addr -> addr -> qry -> x
         , wrapQuery      = \tid src dst ping -> mkping $ wrapAssym tid src dst (, ping)
@@ -232,20 +232,20 @@ unwrapNodes (SendNodes ns) = (ns,ns,())
 
 getNodes :: Client -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],()))
 getNodes client nid addr = do
-    hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
+    -- hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
     reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
-    hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply
+    -- hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply
     return $ fmap unwrapNodes $ join reply
 
-updateRouting :: Client -> Routing -> NodeInfo -> Message -> IO ()
-updateRouting client routing naddr msg = do
+updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO ()
+updateRouting client routing orouter naddr msg = do
     let typ = fst $ dhtMessageType $ fst $ DHTTransport.encrypt (error "updateRouting") msg naddr
         tid = mapMessage (\n24 (n8,_) -> TransactionId n8 n24) msg
-    hPutStrLn stderr $ "updateRouting "++show (typ,tid)
+    -- hPutStrLn stderr $ "updateRouting "++show (typ,tid)
     -- TODO: check msg type
     case prefer4or6 naddr Nothing of
-        Want_IP4 -> updateTable client naddr (orouter routing) (routing4 routing) (committee4 routing) (sched4 routing)
-        Want_IP6 -> updateTable client naddr (orouter routing) (routing6 routing) (committee6 routing) (sched6 routing)
+        Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing)
+        Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing)
 
 updateTable :: Client -> NodeInfo -> OnionRouter -> TVar (R.BucketList NodeInfo) -> TriadCommittee NodeId SockAddr -> TVar (Int.PSQ POSIXTime) -> IO ()
 updateTable client naddr orouter tbl committee sched = do
@@ -262,7 +262,7 @@ toxKademlia client committee orouter var sched
                    { tblTransition = \tr -> do
                         io1 <- transitionCommittee committee tr
                         io2 <- touchBucket toxSpace (15*60) var sched tr
-                        hookBucketList orouter tr
+                        hookBucketList toxSpace var orouter tr
                         return $ do
                             io1 >> io2
                             {-
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
index 959d689c..d0c57416 100644
--- a/src/Network/Tox/NodeId.hs
+++ b/src/Network/Tox/NodeId.hs
@@ -223,7 +223,10 @@ instance Sized NodeInfo where
 instance S.Serialize NodeInfo where
     get = do
         addrfam <- S.get :: S.Get Word8
-        ip <- getIP addrfam
+        let fallback = do -- FIXME: Handle unrecognized address families.
+                IPv6 <$> S.get
+                return $ IPv6 (read "::" :: IPv6)
+        ip <- getIP addrfam <|> fallback
         port <- S.get :: S.Get PortNumber
         nid <- S.get
         return $ NodeInfo nid ip port
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 08f5cabd..91dd843e 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Network.Tox.Onion.Handlers where
 
+import Network.Kademlia.Search
 import Network.Tox.DHT.Transport
 import Network.Tox.DHT.Handlers hiding (Message,Client)
 import Network.Tox.Onion.Transport
@@ -11,9 +13,11 @@ import qualified Data.Wrapper.PSQ             as PSQ
          ;import Data.Wrapper.PSQ             (PSQ)
 import Crypto.Error.Types                     (CryptoFailable (..),
                                                throwCryptoError)
+import Control.Arrow
 
 import System.IO
 import qualified Data.ByteArray               as BA
+import Data.Function
 import Data.Serialize as S
 import qualified Data.Wrapper.PSQInt as Int
 import Network.Kademlia
@@ -59,23 +63,27 @@ classify msg = go msg
 -- The reason for this 20 second timeout in toxcore is that it gives a reasonable
 -- time (20 to 40 seconds) for a peer to announce himself while taking in count
 -- all the possible delays with some extra seconds.
+-- dhtd: src/Network/Tox/Onion/Handlers.hs:(67,1)-(101,23): Non-exhaustive patterns in function announceH
 announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
-announceH routing toks keydb (OnionToOwner naddr retpath) req = do
+announceH routing toks keydb oaddr req = do
     case () of
         _ | announcePingId req == zeros32
           -> go False
 
         _ -> let Nonce32 bs = announcePingId req
                  tok        = fromPaddedByteString 32 bs
-             in checkToken toks naddr tok >>= go
+             in checkToken toks (onionNodeInfo oaddr) tok >>= go
         `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
  where
     go withTok = do
+        let naddr = onionNodeInfo oaddr
         ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
         tm <- getPOSIXTime
-        let storing = (nodeId naddr == announceSeeking req)
+        let storing = case oaddr of
+                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
+                        _                  -> Nothing
         record <- atomically $ do
-            when (withTok && storing) $ do
+            forM_ storing $ \retpath -> when withTok $ do
                 let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
                     -- Note: The following distance calculation assumes that
                     -- our nodeid doesn't change and is the same for both
@@ -85,12 +93,12 @@ announceH routing toks keydb (OnionToOwner naddr retpath) req = do
                 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
             ks <- readTVar keydb
             return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
-        newtok <- if storing
-                    then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
-                    else return $ zeros32
+        newtok <- maybe (return $ zeros32)
+                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
+                        storing
         let k = case record of
                 Nothing                    -> NotStored newtok
-                Just _  | storing          -> Acknowledged newtok
+                Just _  | isJust storing   -> Acknowledged newtok
                 Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
         let response = AnnounceResponse k ns
         hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
@@ -151,3 +159,58 @@ handlers net routing toks keydb AnnounceType
     $ announceH routing toks keydb
 handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
 
+toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> Client r
+               -> Search NodeId (IP, PortNumber) (Maybe Nonce32) NodeInfo PublicKey
+toxidSearch getTimeout client = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = announce getTimeout client
+    }
+
+announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+                   -> MethodSerializer
+                        TransactionId
+                        (OnionDestination r)
+                        (OnionMessage Identity)
+                        PacketKind
+                        AnnounceRequest
+                        (Maybe AnnounceResponse)
+announceSerializer getTimeout = MethodSerializer
+    { methodTimeout = getTimeout
+    , method = AnnounceType
+    , wrapQuery = \(TransactionId n8 n24) src dst req ->
+        -- :: tid -> addr -> addr -> a -> OnionMessage Identity
+        OnionAnnounce $ Assym
+            { -- The public key is our real long term public key if we want to
+              -- announce ourselves, a temporary one if we are searching for
+              -- friends.
+              senderKey = fromJust $ onionKey src -- TODO: FIXME: this should be a temporary alias key
+            , assymNonce = n24
+            , assymData = Identity (req, n8)
+            }
+    , unwrapResponse = \case -- :: OnionMessage Identity -> b
+        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
+        _                              -> Nothing
+    }
+
+unwrapAnnounceResponse :: AnnounceResponse -> ([NodeInfo], [PublicKey], Maybe Nonce32)
+unwrapAnnounceResponse (AnnounceResponse is_stored (SendNodes ns))
+    = case is_stored of
+        NotStored n32    -> (ns, [],  Just n32)
+        SendBackKey k    -> (ns, [k], Nothing)
+        Acknowledged n32 -> (ns, [],  Just n32)
+
+announce :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> Client r
+            -> NodeId
+            -> NodeInfo
+            -> IO (Maybe ([NodeInfo],[PublicKey],Maybe Nonce32))
+announce getTimeout client nid ni =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    let oaddr = OnionDestination ni Nothing
+    mb <- QR.sendQuery client (announceSerializer getTimeout) (AnnounceRequest zeros32 nid zeroID) oaddr
+    maybe (if n>0 then loop $! n - 1 else return Nothing)
+          (return . Just . unwrapAnnounceResponse)
+          $ join mb
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index a3c1950f..b5ac748a 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -35,6 +35,8 @@ module Network.Tox.Onion.Transport
     , peelSymmetric
     , OnionRoute(..)
     , N3
+    , onionKey
+    , onionNodeInfo
     ) where
 
 import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
@@ -42,10 +44,11 @@ import Network.QueryResponse
 import Crypto.Tox hiding (encrypt,decrypt)
 import Network.Tox.NodeId
 import qualified Crypto.Tox as ToxCrypto
-import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes,nodeInfo,DHTPublicKey,asymNodeInfo)
+import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey,asymNodeInfo)
 
 import Debug.Trace
 import Control.Arrow
+import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.ByteString  as B
@@ -88,14 +91,23 @@ deriving instance ( Show (f (AnnounceRequest, Nonce8))
                   , Show (f DataToRoute)
                   ) => Show (OnionMessage f)
 
+msgNonce :: OnionMessage f -> Nonce24
+msgNonce (OnionAnnounce a)               = assymNonce a
+msgNonce (OnionAnnounceResponse _ n24 _) = n24
+msgNonce (OnionToRoute _ a)              = assymNonce a
+msgNonce (OnionToRouteResponse a)        = assymNonce a
+
 data OnionDestination r
     = OnionToOwner     NodeInfo (ReturnPath N3) -- ^ Somebody else's path to us.
     | OnionDestination NodeInfo (Maybe r)       -- ^ Our own onion-path.
     deriving Show
 
+onionNodeInfo :: OnionDestination r -> NodeInfo
+onionNodeInfo (OnionToOwner     ni _) = ni
+onionNodeInfo (OnionDestination ni _) = ni
+
 onionKey :: OnionDestination r -> Maybe PublicKey
-onionKey (OnionToOwner     ni _) = Just $ id2key (nodeId ni)
-onionKey (OnionDestination ni _) = Just $ id2key (nodeId ni)
+onionKey od = Just $ id2key . nodeId $ onionNodeInfo od
 
 instance Sized (OnionMessage Encrypted) where
     size = VarSize $ \case
@@ -176,11 +188,19 @@ encodeOnionAddr :: (NodeInfo -> r -> IO (Maybe OnionRoute))
 encodeOnionAddr _ (msg,OnionToOwner ni p) =
     return $ Just ( runPut $ putResponse (OnionResponse p msg)
                   , nodeAddr ni )
-encodeOnionAddr _        (msg,OnionDestination _  Nothing   ) = return Nothing
+encodeOnionAddr _        (msg,OnionDestination _  Nothing   ) = do
+    hPutStrLn stderr $ "ONION encode missing routeid"
+    return Nothing
 encodeOnionAddr getRoute (msg,OnionDestination ni (Just rid)) = do
-    let go route = do
-            return (runPut $ putRequest $ wrapForRoute msg ni route, nodeAddr ni)
-    getRoute ni rid >>= mapM go
+    let go route0 = do
+            let route = route0 { routeNonce = msgNonce msg } -- TODO: This necessary?
+            return ( runPut $ putRequest $ wrapForRoute msg ni route
+                   , nodeAddr $ routeNodeA route)
+        mapM' f x = do
+            hPutStrLn stderr $ "ONION encode sending to  " ++ show ni
+            hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (mapM (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x)
+            mapM f x
+    getRoute ni rid >>= mapM' go
 
 
 forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport
@@ -239,16 +259,19 @@ deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
 instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
          , Sized (ReturnPath n)
          , Serialize (ReturnPath n)
+         , Typeable n
          ) => Serialize (OnionRequest n) where
     get = do
         -- TODO share code with 'getOnionRequest'
-        n24 <- get
+        n24 <- case eqT :: Maybe (n :~: N3) of
+                Just Refl -> return $ Nonce24 zeros24
+                Nothing   -> get
         cnt <- remaining
         let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
         fwd <- isolate fwdsize get
         rpath <- get
         return $ OnionRequest n24 fwd rpath
-    put (OnionRequest n f p) = put n >> put f >> put p
+    put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
 
 -- getRequest :: _
 -- getRequest = OnionRequest <$> get <*> get <*> get
@@ -402,6 +425,7 @@ handleOnionRequest :: forall a proxy n.
                       ( LessThanThree n
                       , KnownPeanoNat n
                       , Sized (ReturnPath n)
+                      , Typeable n
                       ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
 handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
     let n = peanoVal rpath
@@ -414,7 +438,7 @@ handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) =
             hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
             kont
         Right (Addressed dst msg') -> do
-            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "SUCCESS"]
+            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
             sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
             kont
 
@@ -472,9 +496,13 @@ getOnionRequest = do
     path <- get
     return (a,path)
 
-putRequest :: (KnownPeanoNat n, Serialize (OnionRequest n)) => OnionRequest n -> Put
+putRequest :: ( KnownPeanoNat n
+              , Serialize (OnionRequest n)
+              , Typeable n
+              ) => OnionRequest n -> Put
 putRequest req = do
-    putWord8 $ 0x80 + fromIntegral (peanoVal req)
+    let tag = 0x80 + fromIntegral (peanoVal req)
+    when (tag <= 0x82) (putWord8 tag)
     put req
 
 putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
@@ -513,9 +541,14 @@ data AnnounceResponse = AnnounceResponse
 instance Sized AnnounceResponse where
     size = contramap is_stored size <> contramap announceNodes size
 
+getNodeList :: S.Get [NodeInfo]
+getNodeList = do
+    n <- S.get
+    (:) n <$> (getNodeList <|> pure [])
+
 instance S.Serialize AnnounceResponse where
-    get = AnnounceResponse <$> S.get <*> S.get
-    put (AnnounceResponse st ns) = S.put st >> S.put ns
+    get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
+    put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
 
 data DataToRoute = DataToRoute
     { dataFromKey :: PublicKey -- Real public key of sender