WIP Onion routing.

10 files changed, 617 insertions, 93 deletions

diff --git a/OnionRouter.hs b/OnionRouter.hs
index 15304221..7a48aaab 100644
--- a/OnionRouter.hs
+++ b/OnionRouter.hs
@@ -1,5 +1,6 @@
 module OnionRouter where
 
+import Control.Concurrent.Lifted.Instrument
 import Crypto.Tox
 import Network.Kademlia
 import Network.Kademlia.Routing
@@ -7,25 +8,367 @@ import Network.QueryResponse
 import Network.Tox.NodeId
 import Network.Tox.Onion.Transport
 
-import Network.Socket (SockAddr)
+import Control.Arrow
 import Control.Concurrent.STM
+import Control.Monad
+import Crypto.PubKey.Curve25519
+import Crypto.Random
+import Data.Bits
+import qualified Data.ByteString     as B
+import qualified Data.HashMap.Strict as HashMap
+         ;import Data.HashMap.Strict (HashMap)
+import qualified Data.IntMap         as IntMap
+         ;import Data.IntMap         (IntMap)
+import Data.Maybe
+import qualified Data.Serialize      as S
+import Data.Typeable
+import Data.Word
+import qualified Data.Word64Map      as W64
+         ;import Data.Word64Map      (Word64Map, fitsInInt)
+import Network.Socket
+import System.Endian
+import System.IO
 
 newtype RouteId = RouteId Int
  deriving Show
 
-data OnionRouter
+data OnionRouter = OnionRouter
+    { pendingQueries :: TVar (Word64Map NodeId)
+    , routeMap :: TVar (IntMap RouteRecord)
+    , trampolineNodes :: TVar (IntMap NodeInfo)
+    , trampolineIds :: TVar (HashMap NodeId Int)
+    , trampolineCount :: TVar Int
+    , onionDRG :: TVar ChaChaDRG
+    , routeThread :: ThreadId
+    , pendingRoutes :: IntMap (TVar Bool)
+    , routeLog :: TChan String
+    }
+
+data RouteRecord = RouteRecord
+    { storedRoute :: OnionRoute
+    , responseCount :: Int
+    , timeoutCount :: Int
+    }
+
+-- Onion paths have different timeouts depending on whether the path is
+-- confirmed or unconfirmed. Unconfirmed paths (paths that core has never
+-- received any responses from) have a timeout of 4 seconds with 2 tries before
+-- they are deemed non working. This is because, due to network conditions,
+-- there may be a large number of newly created paths that do not work and so
+-- trying them a lot would make finding a working path take much longer. The
+-- timeout for a confirmed path (from which a response was received) is 10
+-- seconds with 4 tries without a response. A confirmed path has a maximum
+-- lifetime of 1200 seconds to make possible deanonimization attacks more
+-- difficult.
+timeoutForRoute :: RouteRecord -> Int
+timeoutForRoute RouteRecord{ responseCount = 0 } = 4000000
+timeoutForRoute RouteRecord{ responseCount = _ } = 10000000
+
+freshRoute :: OnionRoute -> RouteRecord
+freshRoute r = RouteRecord
+    { storedRoute = r
+    , responseCount = 0
+    , timeoutCount = 0
+    }
+
+gotResponse :: RouteRecord -> RouteRecord
+gotResponse rr = rr
+    { responseCount = succ $ responseCount rr
+    , timeoutCount = 0
+    }
+
+gotTimeout :: RouteRecord -> RouteRecord
+gotTimeout rr = rr
+    { timeoutCount = succ $ timeoutCount rr
+    }
+
+data RouteEvent = BuildRoute RouteId
 
 newOnionRouter :: IO OnionRouter
-newOnionRouter = return _todo
+newOnionRouter = do
+    drg0 <- drgNew
+    or <- atomically $ do
+        chan <- newTChan
+        drg <- newTVar drg0
+        forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
+        pq <- newTVar W64.empty
+        rm <- newTVar IntMap.empty
+        tn <- newTVar IntMap.empty
+        ti <- newTVar HashMap.empty
+        tc <- newTVar 0
+        vs <- sequence $ replicate 12 (newTVar True)
+        rlog <- newTChan
+        return OnionRouter
+            { pendingRoutes = IntMap.fromList $ zip [0..11] vs
+            , onionDRG = drg
+            , pendingQueries = pq
+            , routeMap = rm
+            , trampolineNodes = tn
+            , trampolineIds = ti
+            , trampolineCount = tc
+            , routeLog = rlog
+            , routeThread = error "Failed to invoke forkRouteBuilder"
+            }
+    return or
+
+forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO [NodeInfo]) -> IO OnionRouter
+forkRouteBuilder or getnodes = do
+    tid <- forkIO $ do
+        me <- myThreadId
+        labelThread me "OnionRouter"
+        forever $ do
+            let checkRebuild rid want_build stm = flip orElse stm $ do
+                    readTVar want_build >>= check
+                    writeTVar want_build False
+                    return $ BuildRoute $ RouteId rid
+            io <- atomically $
+                   (readTChan (routeLog or) >>= return . hPutStrLn stderr)
+                `orElse`
+                   (IntMap.foldrWithKey checkRebuild retry (pendingRoutes or)
+                        >>= return . handleEvent getnodes or { routeThread = me })
+            io
+    return or { routeThread = tid }
+
+generateNodeId :: MonadRandom m => m NodeId
+generateNodeId = either (error "unable to make random nodeid")
+                        id
+                 . S.decode <$> getRandomBytes 32
+
+distinct3by :: Eq t => (a -> t) -> a -> a -> a -> Bool
+distinct3by f a b c = f a /= f b && f b /= f c && f c /= f a
+
+-- The two integer functions below take an [inclusive,inclusive] range.
+randomR :: (DRG g, Integral a) => (a, a) -> g -> (a, g)
+randomR (l,h) = randomIvalInteger (toInteger l, toInteger h)
+
+next :: DRG g => g -> (Int,g)
+next g = withDRG g $ do bs <- getRandomBytes $ if fitsInInt (Proxy :: Proxy Word64)
+                                                then 8
+                                                else 4
+                        either (return . error) return $ S.decode bs
+
+randomIvalInteger :: (DRG g, Num a) => (Integer, Integer) -> g -> (a, g)
+randomIvalInteger (l,h) rng
+ | l > h     = randomIvalInteger (h,l) rng
+ | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
+     where
+       (genlo, genhi) = (minBound :: Int, maxBound :: Int) -- genRange :: RandomGen g => g -> (Int, Int)
+       b = fromIntegral genhi - fromIntegral genlo + 1
+
+       -- Probabilities of the most likely and least likely result
+       -- will differ at most by a factor of (1 +- 1/q).  Assuming the RandomGen
+       -- is uniform, of course
+
+       -- On average, log q / log b more random values will be generated
+       -- than the minimum
+       q = 1000
+       k = h - l + 1
+       magtgt = k * q
+
+       -- generate random values until we exceed the target magnitude
+       f mag v g | mag >= magtgt = (v, g)
+                 | otherwise = v' `seq`f (mag*b) v' g' where
+                        (x,g') = next g -- next :: RandomGen g => g -> (Int, g)
+                        v' = (v * b + (fromIntegral x - fromIntegral genlo))
+
+selectTrampolines :: OnionRouter -> STM [NodeInfo]
+selectTrampolines or = do
+    cnt <- readTVar (trampolineCount or)
+    drg0 <- readTVar (onionDRG or)
+    ts <- readTVar (trampolineNodes or)
+    let (a, drg1) = randomR (0,cnt - 1) drg0
+        (b0, drg2) = randomR (0,cnt - 2) drg1
+        (c0, drg ) = randomR (0,cnt - 3) drg2
+        b | b0 < a    = b0
+          | otherwise = b0 + 1
+        c1 | c0 < a     = c0
+           | otherwise  = c0 + 1
+        c | c1 < b    = c1
+          | otherwise = c1 + 1
+        ns = mapMaybe (\n -> IntMap.lookup n ts) [a,b,c]
+    ns' <- case ns of
+            [an,bn,cn] -> do check $ distinct3by nodeClass an bn cn
+                             return ns
+            _          -> retry
+    writeTVar (onionDRG or) drg
+    return ns'
+
+handleEvent :: (NodeId -> NodeInfo -> IO [NodeInfo]) -> OnionRouter -> RouteEvent -> IO ()
+handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
+    hPutStrLn stderr $ "ONION Rebuilding RouteId " ++ show rid
+    mb <- join . atomically $ do
+        ts <- selectTrampolines or
+        drg <- readTVar (onionDRG or)
+        [av,bv,cv] <- sequence $ replicate 3 (newTVar Nothing)
+        let (getr, drg') = withDRG drg $ do
+                n24 <- Nonce24 <$> getRandomBytes 24
+                asec <- generateSecretKey -- Three aliases
+                bsec <- generateSecretKey
+                csec <- generateSecretKey
+                aq <- generateNodeId -- Three queries
+                bq <- generateNodeId
+                cq <- generateNodeId
+                sel <- B.head <$> getRandomBytes 1 -- Three two-bit result selectors (6 bits)
+                let asel = sel .&. 0x3
+                    bsel = shiftR sel 2 .&. 0x3
+                    csel = shiftR sel 4 .&. 0x3
+                    sendq s q ni = listToMaybe . drop (fromIntegral s) <$> getnodes q ni
+                    sendqs = do
+                        forkIO $ sendq asel aq (ts !! 0) >>= atomically . writeTVar av . Just
+                        forkIO $ sendq bsel bq (ts !! 1) >>= atomically . writeTVar bv . Just
+                        forkIO $ sendq csel cq (ts !! 2) >>= atomically . writeTVar cv . Just
+                        atomically $ do -- Wait for all 3 results.
+                            rs <- catMaybes <$> sequence [readTVar av,readTVar bv,readTVar cv]
+                            case rs of [_,_,_] -> do
+                                                    return $ catMaybes rs
+                                                    -- self <- IntMap.lookup (-1) <$> readTVar (trampolineNodes or)
+                                                    -- return $ maybe (catMaybes rs) (\x -> [x,x,x]) self
+                                       _       -> retry
+                return $ do
+                    nodes <- sendqs
+                    hPutStr stderr $ unlines
+                        [ "ONION trampolines:   " ++ show ts
+                        , "ONION query results: " ++ show nodes ]
+                    case nodes of
+                        [a,b,c] -> do -- | distinct3by nodeClass a b c -> do
+                            return $ Just OnionRoute
+                                { routeNonce = n24
+                                , routeAliasA = asec
+                                , routeAliasB = bsec
+                                , routeAliasC = csec
+                                , routeNodeA = a
+                                , routeNodeB = b
+                                , routeNodeC = c
+                                }
+                        _ -> return Nothing
+        writeTVar (onionDRG or) drg'
+        return $ getr
+    atomically $ maybe (writeTVar (pendingRoutes or IntMap.! rid) True)
+                       (\r -> modifyTVar' (routeMap or)
+                                          (IntMap.insert rid $ freshRoute r))
+                       mb
+    case mb of
+        Just _  -> hPutStrLn stderr $ "ONION Finished RouteId " ++ show rid
+        Nothing -> hPutStrLn stderr $ "ONION Failed RouteId " ++ show rid
+
+routeId :: Nonce8 -> RouteId
+routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12
 
 lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (NodeInfo, RouteId))
-lookupSender _ _ _ = return Nothing -- todo
+lookupSender or saddr (Nonce8 w8) = do
+    result <- atomically $ do
+        ks <- readTVar (pendingQueries or)
+        let r = W64.lookup w8 ks
+        writeTChan (routeLog or) $ "ONION lookupSender " ++ unwords [show w8, "->", show r]
+        return r
+    return $ do
+        nid <- result
+        ni <- either (const Nothing) Just $ nodeInfo nid saddr
+        Just (ni, routeId (Nonce8 w8))
 
 lookupRoute :: OnionRouter -> NodeInfo -> RouteId -> IO (Maybe OnionRoute)
-lookupRoute _ _ _ = return Nothing -- todo
+lookupRoute or ni (RouteId rid) = do
+    mb <- atomically $ IntMap.lookup rid <$> readTVar (routeMap or)
+    return $ storedRoute <$> mb
+
+lookupTimeout :: OnionRouter -> Nonce8 -> OnionDestination r -> STM (OnionDestination RouteId, Int)
+lookupTimeout or n8 (OnionDestination ni Nothing) = do
+    let RouteId rid = routeId n8
+    mrr <- IntMap.lookup rid <$> readTVar (routeMap or)
+    readTVar (routeMap or) >>= \rm -> writeTChan (routeLog or) $ "ONION lookupTimeout " ++ unwords [show rid,show (IntMap.keys rm)]
+    case mrr of
+        Just rr -> return ( OnionDestination ni (Just $ routeId n8), timeoutForRoute rr)
+        Nothing -> return ( OnionDestination ni Nothing            , 0 )
+
+hookQueries :: OnionRouter -> (tid -> Nonce8)
+                           -> TransactionMethods d tid (OnionDestination r) x
+                           -> TransactionMethods d tid (OnionDestination r) x
+hookQueries or t8 tmethods = TransactionMethods
+    { dispatchRegister = \mvar od d -> do --  :: MVar x -> d -> STM (tid, d)
+        (tid,d') <- dispatchRegister tmethods mvar od d
+        let Nonce8 w8 = t8 tid
+            ni = onionNodeInfo od
+        modifyTVar' (pendingQueries or) (W64.insert w8 (nodeId ni))
+        writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show w8, ":=", show ni ]
+        return (tid,d')
+    , dispatchResponse = \tid x d -> do -- :: tid -> x -> d -> STM (d, IO ())
+        let (Nonce8 w8, RouteId rid) = (id &&& routeId) $ t8 tid
+        modifyTVar' (pendingQueries or) (W64.delete w8)
+        modifyTVar' (routeMap or) (IntMap.adjust gotResponse rid)
+        writeTChan (routeLog or) $ "ONION query del " ++ show w8
+        dispatchResponse tmethods tid x d
+    , dispatchCancel = \tid d -> do -- :: tid -> d -> STM d
+        let (Nonce8 w8, RouteId rid) = (id &&& routeId) $ t8 tid
+        modifyTVar' (pendingQueries or) (W64.delete w8)
+        writeTChan (routeLog or) $ "ONION query can " ++ show w8
+        modifyTVar' (routeMap or) (IntMap.adjust gotTimeout rid)
+        let expireRoute = writeTVar (pendingRoutes or IntMap.! rid) True
+        rr <- IntMap.lookup rid <$> readTVar (routeMap or)
+        case rr of
+            Just RouteRecord{ responseCount=0
+                            , timeoutCount = c } | c >= 2 -> expireRoute
+            Just RouteRecord{ timeoutCount = c } | c >= 4 -> expireRoute
+            _ -> return ()
+        dispatchCancel tmethods tid d
+    }
+
+
+addtramp :: NodeInfo -> Maybe (HashMap NodeId NodeInfo) -> Maybe (HashMap NodeId NodeInfo)
+addtramp ni Nothing  = Just $ HashMap.singleton (nodeId ni) ni
+addtramp ni (Just m) = Just $ HashMap.insert (nodeId ni) ni m
+
+deltramp :: NodeInfo -> Maybe (HashMap NodeId v) -> Maybe (HashMap NodeId v)
+deltramp ni Nothing  = Nothing
+deltramp ni (Just m) = case HashMap.delete (nodeId ni) m of
+                        m' | HashMap.null m' -> Nothing
+                        m'                   -> Just m'
+
+hookBucketList :: KademliaSpace NodeId NodeInfo -> TVar (BucketList NodeInfo) ->  OnionRouter -> RoutingTransition NodeInfo -> STM ()
+hookBucketList kademlia bkts0 or (RoutingTransition ni Accepted) = do
+    s <- do
+        drg0 <- readTVar (onionDRG or)
+        bkts <- readTVar bkts0
+        let antibias = 2 ^ bucketNumber kademlia (nodeId ni) bkts
+            (s,drg)  = randomR (0,antibias - 1) drg0
+        writeTVar (onionDRG or) drg
+        -- let self = (thisNode bkts) { nodeIP = read "127.0.0.1" }
+        -- modifyTVar' (trampolineNodes or) (IntMap.insert (-1) self)
+        return s
+    -- debias via stochastic filter
+    when (s == 0) $ do
+    ns <- readTVar (trampolineIds or)
+    case HashMap.lookup (nodeId ni) ns of
+        Just _ -> return ()
+        Nothing -> do
+            cnt <- readTVar (trampolineCount or)
+            writeTChan (routeLog or) $ "ONION trampoline Accepted " ++ unwords [show cnt, show ni]
+            modifyTVar' (trampolineIds or) (HashMap.insert (nodeId ni) cnt)
+            modifyTVar' (trampolineNodes or) (IntMap.insert cnt ni)
+            writeTVar (trampolineCount or) (succ cnt)
+hookBucketList _ _ or (RoutingTransition ni Stranger) = do
+    ns <- readTVar (trampolineIds or)
+    case HashMap.lookup (nodeId ni) ns of
+        Just n -> do writeTVar (trampolineIds or) (HashMap.delete (nodeId ni) ns)
+                     cnt <- pred <$> readTVar (trampolineCount or)
+                     writeTVar (trampolineCount or) cnt
+                     if n == cnt
+                        then modifyTVar' (trampolineNodes or) (IntMap.delete n)
+                        else do lastnode <- (IntMap.! cnt) <$> readTVar (trampolineNodes or)
+                                modifyTVar' (trampolineNodes or) (IntMap.insert n lastnode . IntMap.delete cnt)
+                     writeTChan (routeLog or) $ "ONION trampoline Stranger " ++ unwords [show n,show ni]
+        Nothing -> return ()
+hookBucketList _ _ _ _ = return () -- ignore Applicant event.
+
+newtype IPClass = IPClass Word32
+ deriving Eq
+
+ipkey :: IPClass -> Int
+ipkey (IPClass k) = fromIntegral k
 
-hookQueries :: OnionRouter -> (tid -> Nonce8) -> TransactionMethods d tid x -> TransactionMethods d tid x
-hookQueries _ n8 tmethods = tmethods -- todo
+nodeClass :: NodeInfo -> IPClass
+nodeClass = ipClass. nodeAddr
 
-hookBucketList :: OnionRouter -> RoutingTransition ni -> STM ()
-hookBucketList _ _ = return () -- todo
+ipClass :: SockAddr -> IPClass
+ipClass (SockAddrInet _ addr)                = IPClass (fromBE32 addr .&. 0xFF000000)
+ipClass (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
+ipClass _                                    = IPClass 0 -- unreachable.
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 0b208362..1ab2778a 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -45,6 +45,7 @@ import Control.Concurrent.Lifted
 import GHC.Conc                  (labelThread)
 #endif
 
+import Crypto.Tox (zeros32)
 import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.Kademlia.Search
@@ -68,6 +69,7 @@ import Data.Ord
 import Data.Time.Clock.POSIX
 import qualified Network.Tox.DHT.Transport as Tox
 import qualified Network.Tox.DHT.Handlers as Tox
+import qualified Network.Tox.Onion.Transport as Tox
 import qualified Network.Tox.Onion.Handlers as Tox
 import Data.Typeable
 
@@ -99,7 +101,7 @@ data DHTQuery nid ni = forall addr r tok.
                         , Typeable r
                         )=> DHTQuery
     { qsearch  :: Search nid addr tok ni r
-    , qhandler :: ni -> nid -> IO ([ni], [r], tok)
+    , qhandler :: ni -> nid -> IO ([ni], [r], tok) -- ^ Invoked on local node, when there is no query destination.
     , qshowR   :: r -> String
     , qshowTok :: tok -> Maybe String
     }
@@ -585,8 +587,21 @@ main = do
                                                         (\ni -> fmap Tox.unwrapNodes
                                                                 . Tox.getNodesH (Tox.toxRouting tox) ni
                                                                 . Tox.GetNodes)
-                                                        show
+                                                        show -- NodeInfo
                                                         (const Nothing))
+                                    , ("toxid", DHTQuery (Tox.toxidSearch (Tox.onionTimeout tox) $ Tox.toxOnion tox)
+                                                         -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
+                                                         (\ni nid ->
+                                                            -- _todo :: IO Tox.AnnounceResponse
+                                                            --       -> IO ([Tox.NodeInfo], [Crypto.PubKey.Curve25519.PublicKey], b0)
+                                                            Tox.unwrapAnnounceResponse
+                                                                <$> Tox.announceH (Tox.toxRouting tox)
+                                                                                  (Tox.toxTokens tox)
+                                                                                  (Tox.toxAnnouncedKeys tox)
+                                                                                  (Tox.OnionDestination ni Nothing)
+                                                                                  (Tox.AnnounceRequest zeros32 nid Tox.zeroID))
+                                                         show -- PublicKey
+                                                         (const Nothing)) -- TODO: show token
                                     ]
                     , dhtParseId  = readEither :: String -> Either String Tox.NodeId
                     , dhtSearches = toxSearches
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