3 files changed, 732 insertions, 2 deletions

diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 746d8667..c233492d 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -67,7 +67,7 @@ import qualified Network.Tox.Onion.Handlers  as Onion
 import qualified Network.Tox.Onion.Transport as Onion
 import Network.Tox.Transport
 import Network.Tox.TCP (tcpClient)
-import OnionRouter
+import Network.Tox.Onion.Routes
 import Network.Tox.ContactInfo
 import Text.XXD
 import DPut
diff --git a/dht/src/Network/Tox/Onion/Routes.hs b/dht/src/Network/Tox/Onion/Routes.hs
new file mode 100644
index 00000000..c054b99e
--- /dev/null
+++ b/dht/src/Network/Tox/Onion/Routes.hs
@@ -0,0 +1,730 @@
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE RankNTypes               #-}
+module Network.Tox.Onion.Routes where
+
+import Control.Concurrent.ThreadUtil
+import Crypto.Tox
+import Network.Address
+import Network.Kademlia
+import Network.Kademlia.Bootstrap
+import Network.Kademlia.Routing as R
+import Network.Kademlia.Search
+import Network.QueryResponse
+import Network.QueryResponse.TCP
+import Network.Tox.NodeId
+import Network.Tox.Onion.Transport as Onion
+import qualified Data.Tox.Relay as TCP
+import qualified Network.Tox.TCP as TCP
+import qualified TCPProber as TCP
+
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TArray
+import Control.Monad
+import Crypto.Random
+import Data.Array.MArray
+import Data.Bits
+import Data.Bool
+import Data.List
+import qualified Data.ByteString     as B
+import Data.Functor.Identity
+import Data.Hashable
+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 Data.Ord
+import qualified Data.Serialize      as S
+import Data.Time.Clock.POSIX
+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.Timeout
+
+-- Toxcore saves a maximum of 12 paths: 6 paths are reserved for announcing
+-- ourselves and 6 others are used to search for friends.
+--
+-- Note: This is pointless because a man-in-the-middle attack currently makes
+-- it trivial to glean friend relationships: the storing node can swap the
+-- published to-route key with his own giving him access to one layer of
+-- encryption and thus the real public key of the sender. TODO:
+-- Counter-measures.
+--
+-- Unlike toxcore, we don't currently reserve paths for only-searching or
+-- only-announcing.  Instead, we maintain 12 multi-purpose routes.
+data OnionRouter = OnionRouter
+    { -- | For every query, we remember the destination and source keys
+      -- so we can decrypt the response.
+      pendingQueries  :: TVar (Word64Map PendingQuery)
+      -- | The current 12 routes that may be assigned to outgoing packets.
+    , routeMap        :: TArray Int (Maybe RouteRecord)
+      -- | A set of nodes used to query for random route nodes. These aren't
+      -- used directly in onion routes, they are queried for route nodes that
+      -- are nearby randomly selected ids.
+    , trampolinesUDP :: TrampolineSet NodeInfo
+      -- | A set for TCP relays to use as trampolines when UDP is not available.
+    , trampolinesTCP :: TrampolineSet TCP.NodeInfo
+      -- | True when we need to rely on TCP relays because UDP is apparently unavailable.
+    , tcpMode :: TVar (Maybe Bool) -- Nothing: tcp disabled, False: use trampolinesUDP, True: use trampolinesTCP
+      -- | The pseudo-random generator used to select onion routes.
+    , onionDRG        :: TVar ChaChaDRG
+      -- | Building onion routes happens in a dedicated thread. See 'forkRouteBuilder'.
+    , routeThread     :: ThreadId
+      -- | Each of the 12 routes has a version number here that is set larger
+      -- than the 'routeVersion' set in 'routeMap' when the route should be
+      -- discarded and replaced with a fresh one.
+    , pendingRoutes   :: TArray Int Int
+      -- | Parameters used to implement Kademlia for TCP relays.
+    , tcpKademliaClient :: TCP.TCPClient String Nonce8
+      -- | This thread maintains the TCP relay table.
+    , tcpKademliaThread :: ThreadId
+    , tcpProberState :: TCPCache (SessionProtocol TCP.RelayPacket TCP.RelayPacket)
+    , tcpProber :: TCP.TCPProber
+    , tcpProberThread :: ThreadId
+      -- | Kademlia table of TCP relays.
+    , tcpBucketRefresher :: BucketRefresher NodeId TCP.NodeInfo
+      -- | Debug prints are written to this channel which is then flushed to
+      -- 'routeLogger'.
+    , routeLog        :: TChan String
+      -- | User supplied log function.
+    , routeLogger     :: String -> IO ()
+    }
+
+data PendingQuery = PendingQuery
+    { pendingVersion     :: !Int -- ^ Remembered version number so timeouts can signal a rebuild.
+    , pendingDestination :: OnionDestination RouteId
+    }
+ deriving Show
+
+data RouteRecord = RouteRecord
+    { storedRoute    :: OnionRoute
+    , responseCount  :: !Int
+    , timeoutCount   :: !Int
+    , routeVersion   :: !Int
+    , routeBirthTime :: !POSIXTime
+    }
+ deriving Show
+
+-- 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 12
+-- 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 = _ } = 12000000
+
+freshRoute :: POSIXTime -> OnionRoute -> Maybe RouteRecord -> Maybe RouteRecord
+freshRoute birthday r mrec = Just $ RouteRecord
+    { storedRoute    = r
+    , responseCount  = 0
+    , timeoutCount   = 0
+    , routeVersion   = maybe 0 succ $ routeVersion <$> mrec
+    , routeBirthTime = birthday
+    }
+
+modifyArray :: TArray Int r -> (r -> r) -> Int -> STM ()
+modifyArray a f i = do
+    mx <- readArray a i
+    writeArray a i $ f mx
+{-# INLINE modifyArray #-}
+
+gotResponse :: RouteRecord -> RouteRecord
+gotResponse rr = rr
+    { responseCount = succ $ responseCount rr
+    , timeoutCount = 0
+    }
+
+gotTimeout :: RouteRecord -> RouteRecord
+gotTimeout rr = rr
+    { timeoutCount = succ $ timeoutCount rr
+    }
+
+newtype RouteEvent = BuildRoute RouteId
+
+newOnionRouter :: TransportCrypto
+                    -> (String -> IO ())
+                    -> Bool -- is tcp enabled?
+                    -> IO ( OnionRouter
+                          , TVar ( ChaChaDRG
+                                 , Word64Map (Either (Maybe (Bool,TCP.RelayPacket) -> IO ())
+                                                     (Maybe (OnionMessage Identity) -> IO ()))))
+newOnionRouter crypto perror tcp_enabled = do
+    drg0 <- drgNew
+    (rlog,pq,rm) <- atomically $ do
+        rlog <- newTChan
+        pq <- newTVar W64.empty
+        rm <- newArray (0,11) Nothing
+        return (rlog,pq,rm)
+    ((tbl,(tcptbl,tcpcons)),tcp) <- do
+        (tcptbl, client) <- TCP.newClient crypto Left $ \case
+            Left v  -> void . v . Just . (,) False
+            Right v -> \case
+                TCP.OnionPacketResponse x@(OnionAnnounceResponse n8 n24 _) -> do
+                    mod <- lookupSender' pq rlog localhost4 n8
+                    perror $ "TCP announce response from " ++ show mod
+                    forM_ mod $ \od -> do
+                        Onion.decrypt crypto x od >>= \case
+                            Right (y,_) -> do perror $ "decrypted announce response, sending " ++ show y
+                                              let
+                                                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
+                                                                $ onionRouteSpec od
+                                                Nonce8 w8 = n8
+                                              atomically $ do
+                                                modifyTVar' pq (W64.delete w8)
+                                                modifyArray rm (fmap gotResponse) rid
+                                              void $ v $ Just y
+                            _           -> return ()
+                x -> perror $ "Unexpected TCP query result: " ++ show x
+
+        let addr = SockAddrInet 0 0
+            tentative_udp = NodeInfo
+                { nodeId   = key2id $ transportPublic crypto
+                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
+                , nodePort = fromMaybe 0 $ sockAddrPort addr
+                }
+            tentative_info = TCP.NodeInfo tentative_udp (fromIntegral 443)
+        tbl <- atomically $ newTVar
+                          $ R.nullTable (comparing TCP.nodeId)
+                                        (\s -> hashWithSalt s . TCP.nodeId)
+                                        tentative_info
+                                        R.defaultBucketCount
+        return $ (,) (tbl,tcptbl) TCP.TCPClient
+            { tcpCrypto     = crypto
+            , tcpClient     = client
+            , tcpGetGateway = \ni -> do
+                gw <- selectGateway tbl ni
+                writeTChan rlog $ unwords ["Selected TCP Gateway:",show ni,"via",show gw]
+                return gw
+            }
+    or <- atomically $ do
+        -- chan <- newTChan
+        drg <- newTVar drg0
+        -- forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
+        tn <- newTVar IntMap.empty
+        ti <- newTVar HashMap.empty
+        tc <- newTVar 0
+        ttn <- newTVar IntMap.empty
+        tti <- newTVar HashMap.empty
+        ttc <- newTVar 0
+        pr <- newArray (0,11) 0
+        prober <- TCP.newProber
+        refresher <- newBucketRefresher
+                            tbl
+                            (TCP.nodeSearch prober tcp)
+                            (fmap (maybe False $ const True) . TCP.tcpPing (TCP.tcpClient tcp))
+        tcpmode <- newTVar $ if tcp_enabled then Just True else Nothing
+        let o = OnionRouter
+                { pendingRoutes  = pr
+                , onionDRG       = drg
+                , pendingQueries = pq
+                , routeMap       = rm
+                , trampolinesUDP = TrampolineSet
+                    { setNodes     = tn
+                    , setCount     = tc
+                    , setNodeClass = nodeClass
+                    , setIDs       = ti
+                    }
+                , trampolinesTCP = TrampolineSet
+                    { setNodes     = ttn
+                    , setCount     = ttc
+                    , setNodeClass = nodeClass . TCP.udpNodeInfo
+                    , setIDs       = tti
+                    }
+                , tcpMode = tcpmode
+                , tcpKademliaClient = tcp
+                    { TCP.tcpClient =
+                        let c = TCP.tcpClient tcp
+                        in c { clientNet = addHandler perror (handleMessage c)
+                                            $ onInbound (updateTCP o)
+                                            $ clientNet c }
+                    }
+                , tcpBucketRefresher = refresher
+                , routeLog           = rlog
+                , routeThread        = error "forkRouteBuilder not invoked (missing onion route builder thread)."
+                , tcpKademliaThread  = error "forkRouteBuilder not invoked (missing TCP bucket maintenance thread)."
+                , tcpProberState     = tcpcons
+                , tcpProber          = prober
+                , tcpProberThread    = error "forkRouteBuilder not invoked (missing TCP probe thread)."
+                , routeLogger        = perror
+                }
+        return o
+    return (or,tcptbl)
+
+updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO ()
+updateTCP or addr x =
+    let refresher = tcpBucketRefresher or
+        kademlia0 = refreshKademlia refresher
+        kademlia = kademlia0 { kademIO = (kademIO kademlia0)
+                                { tblTransition = \tr -> do
+                                    case refresher of
+                                        BucketRefresher { refreshSearch = sch } -> do
+                                            let spc = searchSpace sch
+                                                bkts = refreshBuckets refresher
+                                            hookBucketList spc bkts or (trampolinesTCP or) tr
+                                    tblTransition (kademIO kademlia0) tr
+                                }
+                             }
+    in insertNode kademlia addr
+
+selectGateway :: TVar (R.BucketList TCP.NodeInfo) -> NodeInfo -> STM (Maybe TCP.NodeInfo)
+selectGateway tbl ni = do
+    ns <- kclosest TCP.tcpSpace 2 (nodeId ni) <$> readTVar tbl
+    return $ listToMaybe ns -- $ dropWhile (\n -> TCP.nodeId n == nodeId ni) ns
+
+quitRouteBuilder :: OnionRouter -> IO ()
+quitRouteBuilder or = do
+    killThread (routeThread or)
+    killThread (tcpKademliaThread or)
+    killThread (tcpProberThread or)
+
+forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> IO OnionRouter
+forkRouteBuilder or getnodes = do
+    bktsThread <- forkPollForRefresh $ tcpBucketRefresher or
+    tcpprobe <- forkIO $ TCP.runProbeQueue (tcpProber or)
+                                           (TCP.tcpClient $ tcpKademliaClient or)
+                                           12
+    labelThread tcpprobe "tcp-probe"
+    tid <- forkIO $ do
+        me <- myThreadId
+        labelThread me "OnionRouter"
+        forever $ do
+            let checkRebuild :: Int -> Int -> STM RouteEvent
+                checkRebuild rid wanted_ver = do
+                    current_ver <- fmap routeVersion <$> readArray (routeMap or) rid
+                    writeTChan (routeLog or) $ "ONION checkRebuild "++show(current_ver,wanted_ver)
+                    check $ maybe True (< wanted_ver) current_ver
+                    return $ BuildRoute $ RouteId rid
+            io <- atomically $ {-# SCC "forkRouteBuilder.log" #-}
+                   (readTChan (routeLog or) >>= return . routeLogger or)
+                `orElse` {-# SCC "forkRouteBuilder.checkRebuild" #-}
+                   (let stms = map (\rid -> checkRebuild rid =<< readArray (pendingRoutes or) rid)
+                                   [0..11]
+                        in do event <- foldr1 orElse stms
+                              return $ handleEvent getnodes or { routeThread = me } event)
+            io
+    return or { routeThread       = tid
+              , tcpKademliaThread = bktsThread
+              , tcpProberThread   = tcpprobe }
+
+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))
+
+-- Repeatedly attempt to select 3 nodes as a secure onion route letting 1 second
+-- elapse between retries.
+--
+-- Only the DRG random seed is updated.  Hopefully another thread will change the
+-- trampolineNodes set so that selection can succeed.
+selectTrampolines :: OnionRouter -> IO (Either [TCP.NodeInfo] [NodeInfo])
+selectTrampolines or = do
+    myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
+    let tset :: (forall x. TrampolineSet x -> STM (Either [x] [x]))
+                -> STM (Either (Either [TCP.NodeInfo] [NodeInfo])
+                               (Either [TCP.NodeInfo] [NodeInfo]))
+        tset f = do
+            mm <- readTVar (tcpMode or)
+            -- TODO: better logic for deciding to use TCP or UDP trampolines.
+            if fromMaybe False mm
+                then left Left  . right Left  <$> f (trampolinesTCP or)
+                else left Right . right Right <$> f (trampolinesUDP or)
+    atomically (tset $ internalSelectTrampolines (onionDRG or)) >>= \case
+        Left ns -> do
+            -- atomically $ writeTChan (routeLog or)
+            routeLogger or $ unwords
+                ( "ONION Discarding insecure trampolines:" : (either (map show) (map show) ns))
+            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines.sleep")
+            case ns of
+                Left  [_,_,_] -> threadDelay 1000000 -- (tcp) wait 1 second if we failed the distinct3by predicate.
+                Right [_,_,_] -> threadDelay 1000000 -- (udp) wait 1 second if we failed the distinct3by predicate.
+                _             -> threadDelay 5000000 -- wait 5 seconds if insufficient nodes.
+            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
+            selectTrampolines or
+        Right ns -> do
+            myThreadId >>= flip labelThread ("OnionRouter")
+            return ns
+
+data TrampolineSet ni = TrampolineSet
+    { -- | A set of nodes used to query for random route nodes. These aren't
+      -- used directly in onion routes, they are queried for route nodes that
+      -- are nearby randomly selected ids.
+      --
+      -- These nodes are chosen from the kademlia buckets and when one of them
+      -- is evicted from a bucket, it is no longer used as a trampoline node.
+      setNodes     :: TVar (IntMap ni)
+      -- | Indicates the current size of 'setNodes'.
+    , setCount     :: TVar Int
+      -- | In order to reduce the likelihood that an attacker will control all
+      -- nodes in a route, we color the nodes with 'IPClass' and require
+      -- distinct colors for each of the hops.
+    , setNodeClass :: ni -> IPClass
+      -- | This map associates 'NodeId' values with the corresponding
+      -- 'trampolineNodes' index.
+    , setIDs       :: TVar (HashMap NodeId Int)
+    }
+
+choose3 :: (Integral a, DRG drg) => drg -> a -> ([a], drg)
+choose3 drg0 cnt = ([a,b,c], drg)
+ where
+        (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
+        [ac,bc] = sort [a,b]
+        c1 | c0 < ac    = c0
+           | otherwise  = c0 + 1
+        c | c1 < bc   = c1
+          | otherwise = c1 + 1
+
+-- Select 3 indices into the trampolineNodes set and returns the associated
+-- nodes provided they are suitable for use in an onion route.  Otherwise, it
+-- returns Left with the nodes that were selected.
+--
+-- The only write this function does to STM state is that the onionDRG random
+-- seed will be updated.
+internalSelectTrampolines :: TVar ChaChaDRG -> TrampolineSet ni -> STM (Either [ni] [ni])
+internalSelectTrampolines setDRG TrampolineSet{..} = do
+    cnt <- readTVar setCount
+    ts <- readTVar setNodes
+    drg0 <- readTVar setDRG
+    let ([a,b,c],drg) = choose3 drg0 cnt
+        ns = mapMaybe (\n -> IntMap.lookup n ts) [a,b,c]
+    ns' <- case ns of
+            [an,bn,cn] | distinct3by setNodeClass an bn cn
+                       -> return $ Right ns
+            _          -> return $ Left ns
+    writeTVar setDRG drg
+    return ns'
+
+handleEvent :: (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> OnionRouter -> RouteEvent -> IO ()
+handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
+    routeLogger or $ "ONION Rebuilding RouteId " ++ show rid
+    mb <- do
+        mts <- selectTrampolines or
+        join . atomically $ do
+        drg <- readTVar (onionDRG or)
+        av <- newTVar Nothing
+        bv <- newTVar Nothing
+        cv <- newTVar Nothing
+        let (getr, drg') = withDRG drg $ do
+                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
+                    cycle' [] = []
+                    cycle' ns = cycle ns
+                    sendq :: Word8 -> NodeId -> Int -> IO (Maybe NodeInfo)
+                    sendq s q ni
+                        | Right ts <- mts = (>>= (listToMaybe . drop (fromIntegral s) . cycle')) <$> getnodes q (ts !! ni)
+                        | Left  ts <- mts = case ni of
+                            0 -> return $ Just $ TCP.udpNodeInfo (ts !! 0)
+                            n -> (>>= (listToMaybe . drop (fromIntegral s) . (\(ns,_,_)->cycle' ns)))
+                                   <$> TCP.getUDPNodes (tcpKademliaClient or) q (TCP.udpNodeInfo $ ts !! n)
+                    sendqs = do
+                        forkLabeled "sendq.asel" $ sendq asel aq 0 >>= atomically . writeTVar av . Just
+                        forkLabeled "sendq.bsel" $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just
+                        forkLabeled "sendq.csel" $ sendq csel cq 2 >>= atomically . writeTVar cv . Just
+                        -- This timeout should be unnecessary... But I'm paranoid.
+                        -- Note: 10 seconds should be sufficient for typical get-nodes queries.
+                        tm <- timeout 30000000 $ 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
+                        maybe (routeLogger or "ONION: Unexpected sendq timeout!" >> return [])
+                              return
+                              tm
+                return $ do
+                    myThreadId >>= flip labelThread ("OnionRouter.sendqs")
+                    let mtcpport = either (Just . TCP.tcpPort . head) (const Nothing) mts
+                    nodes <- case mts of
+                        Right [_,_,_] -> sendqs
+                        Left  [_,_,_] -> sendqs
+                        _             -> return []
+                    myThreadId >>= flip labelThread ("OnionRouter")
+                    routeLogger or $ unlines
+                        [ "ONION trampolines:   " ++ show mts
+                        , "ONION query results: " ++ show nodes ]
+                    case nodes of
+                        [a,b,c] | distinct3by nodeClass a b c -> do
+                            atomically $ do
+                              writeTChan (routeLog or) $ unwords [ "ONION using route:"
+                                                                 , show $ nodeAddr a
+                                                                 , show $ nodeAddr b
+                                                                 , show $ nodeAddr c ]
+                            return $ Just OnionRoute
+                                { routeAliasA = asec
+                                , routeAliasB = bsec
+                                , routeAliasC = csec
+                                , routeNodeA = a
+                                , routeNodeB = b
+                                , routeNodeC = c
+                                , routeRelayPort = mtcpport
+                                }
+                        [a,b,c] -> do
+                            atomically $ writeTChan (routeLog or)
+                                       $ unwords [ "ONION Discarding insecure route:"
+                                                 , show $ nodeAddr a
+                                                 , show $ nodeAddr b
+                                                 , show $ nodeAddr c
+                                                 ]
+                            return Nothing
+                        _ -> return Nothing
+        writeTVar (onionDRG or) drg'
+        return $ getr
+    now <- getPOSIXTime
+    atomically $ maybe (return ()) -- writeTVar (pendingRoutes or IntMap.! rid) True)
+                       (\r -> do modifyArray (routeMap or)
+                                             (freshRoute now r)
+                                             rid
+                                 v <- routeVersion . fromJust <$> readArray (routeMap or) rid
+                                 writeArray (pendingRoutes or) rid v
+                                 )
+                       (mb :: Maybe OnionRoute)
+    case mb of
+        Just _  -> routeLogger or $ "ONION Finished RouteId " ++ show rid
+        Nothing -> routeLogger or $ "ONION Failed RouteId " ++ show rid
+
+
+lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId))
+lookupSender or = lookupSender' (pendingQueries or) (routeLog or)
+
+lookupSender' :: TVar (Word64Map PendingQuery)
+                       -> TChan String
+                       -> SockAddr
+                       -> Nonce8
+                       -> IO (Maybe (OnionDestination RouteId))
+lookupSender' pending log saddr (Nonce8 w8) = do
+    result <- atomically $ do
+        ks <- readTVar pending
+        let r = W64.lookup w8 ks
+        writeTChan log $ "ONION lookupSender " ++ unwords [show w8, "->", show r]
+        return r
+    return $ do
+        od <- result
+        let nid = nodeId $ onionNodeInfo $ pendingDestination od
+        ni <- either (const Nothing) Just $ nodeInfo nid saddr
+        Just (OnionDestination (onionAliasSelector $ pendingDestination od)
+                               ni
+                               (Just $ routeId nid))
+
+lookupRoute :: OnionRouter -> NodeInfo -> RouteId -> IO (Maybe OnionRoute)
+lookupRoute or ni (RouteId rid) = do
+    mb <- atomically $ readArray (routeMap or) rid
+    return $ storedRoute <$> mb
+
+lookupTimeout :: OnionRouter -> OnionDestination r -> STM (OnionDestination RouteId, Int)
+lookupTimeout or (OnionDestination asel ni Nothing) = do
+    let RouteId rid = routeId (nodeId ni)
+    mrr <- readArray (routeMap or) rid
+    writeTChan (routeLog or) $ unwords ["ONION lookupTimeout " ,show rid]
+    case mrr of
+        Just rr -> return ( OnionDestination asel ni (Just $ RouteId rid), timeoutForRoute rr)
+        Nothing -> return ( OnionDestination asel ni Nothing             , 0 )
+
+hookQueries :: OnionRouter -> (tid -> Nonce8)
+                           -> TransactionMethods d tid (OnionDestination RouteId) x
+                           -> TransactionMethods d tid (OnionDestination RouteId) x
+hookQueries or t8 tmethods = TransactionMethods
+    { dispatchRegister = \nowPlusExpiry mvar od d -> {-# SCC "hookQ.dispatchRegister" #-} do --  :: MVar x -> d -> STM (tid, d)
+        let ni = onionNodeInfo od
+            rid@(RouteId ridn) = fromMaybe (routeId (nodeId ni)) $ onionRouteSpec od
+        wanted <- {-# SCC "hookQ.wanted" #-} (readArray (pendingRoutes or) ridn)
+        mr <- {-# SCC "hookQ.mr_action" #-} (readArray (routeMap or) ridn)
+        -- Block query until a route is ready.
+        check $ fromMaybe False $ do
+            RouteRecord{routeVersion=rv} <- {-# SCC "hookQ.mr" #-} mr
+            return $ wanted <= rv
+        (tid,d') <- dispatchRegister tmethods nowPlusExpiry mvar od d
+        let Nonce8 w8 = t8 tid
+            od' = case od of
+                OnionDestination {} -> od { onionRouteSpec = Just rid }
+                OnionToOwner a b    -> OnionToOwner a b -- Type cast.
+        let pq = PendingQuery { pendingDestination = od'
+                              , pendingVersion = maybe 0 routeVersion mr
+                              }
+        pqs <- readTVar (pendingQueries or)
+        -- check $ W64.size pqs < 20
+        modifyTVar' (pendingQueries or) (W64.insert w8 pq)
+        writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show (Just $ pendingVersion pq,w8), ":=", show ni ]
+        return (tid,d')
+    , dispatchResponse = \tid x d -> {-# SCC "hookQ.dispatchResponse" #-} do -- :: tid -> x -> d -> STM (d, IO ())
+        let Nonce8 w8 = t8 tid
+        mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
+        modifyTVar' (pendingQueries or) (W64.delete w8)
+        forM_ mb $ \pq -> do
+            let od = pendingDestination pq
+                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
+                                $ onionRouteSpec od
+            modifyArray (routeMap or) (fmap gotResponse) rid
+        writeTChan (routeLog or) $ "ONION query del " ++ show (fmap pendingVersion mb, w8)
+        dispatchResponse tmethods tid x d
+    , dispatchCancel = \tid d -> {-# SCC "hookQ.dispatchCancel" #-} do -- :: tid -> d -> STM d
+        let Nonce8 w8 = t8 tid
+        mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
+        modifyTVar' (pendingQueries or) (W64.delete w8)
+        forM_ mb $ \pq -> do
+            let od = pendingDestination pq
+                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
+                                $ onionRouteSpec od
+            mrr <- readArray (routeMap or) rid
+            forM_ mrr $ \rr -> do
+            when (routeVersion rr == pendingVersion pq) $ do
+            let expireRoute = modifyArray (pendingRoutes or) expire rid
+                expire ver | ver <= succ (pendingVersion pq) = succ (pendingVersion pq)
+                           | otherwise                       = ver
+            modifyArray (routeMap or) (fmap gotTimeout) rid
+            case rr of
+                RouteRecord{ responseCount = 0
+                           , timeoutCount  = c
+                           , routeVersion = v } | c >= 5 -> expireRoute
+                RouteRecord{ responseCount = 1
+                           , timeoutCount = c
+                           , routeVersion = v } | c >= 10 -> expireRoute
+                RouteRecord{ timeoutCount = c
+                           , routeVersion = v } | c >= 20 -> expireRoute
+                _ -> return ()
+        writeTChan (routeLog or) $ "ONION query can " ++ show (fmap pendingVersion mb, w8)
+        dispatchCancel tmethods tid d
+    }
+
+
+-- hookBucketList :: KademliaSpace NodeId NodeInfo -> TVar (BucketList NodeInfo) ->  OnionRouter -> RoutingTransition NodeInfo -> STM ()
+hookBucketList :: Show ni =>
+                        KademliaSpace NodeId ni
+                        -> TVar (BucketList ni)
+                        -> OnionRouter
+                        -> TrampolineSet ni
+                        -> RoutingTransition ni
+                        -> STM ()
+hookBucketList kademlia bkts0 or TrampolineSet{..} (RoutingTransition ni Accepted) = do
+    (s,antibias) <- do
+        drg0 <- readTVar (onionDRG or)
+        bkts <- readTVar bkts0
+        let antibias = 2 ^ bucketNumber kademlia (kademliaLocation kademlia ni) bkts
+            (s,drg)  = randomR (0,antibias - 1) drg0
+        writeTVar (onionDRG or) drg
+        {-
+        do -- Store localhost as trampoline node (-1).
+           -- This is potentionally useful for testing.
+           let self = (thisNode bkts) { nodeIP = read "127.0.0.1" }
+           modifyTVar' setNodes (IntMap.insert (-1) self)
+        -}
+        return (s::Int,antibias)
+    -- debias via stochastic filter
+    when (s == 0) $ do
+    ns <- readTVar setIDs -- (trampolineIds or)
+    case HashMap.lookup (kademliaLocation kademlia ni) ns of
+        Just _ -> return ()
+        Nothing -> do
+            cnt <- readTVar setCount
+            writeTChan (routeLog or) $ "ONION trampoline Accepted " ++ unwords ["s="++show (s,antibias),show cnt, show ni]
+            modifyTVar' setIDs (HashMap.insert (kademliaLocation kademlia ni) cnt)
+            modifyTVar' setNodes (IntMap.insert cnt ni)
+            writeTVar setCount (succ cnt)
+hookBucketList kademlia _ or TrampolineSet{..} (RoutingTransition ni Stranger) = do
+    ns <- readTVar setIDs
+    case HashMap.lookup (kademliaLocation kademlia ni) ns of
+        Just n -> do writeTVar setIDs (HashMap.delete (kademliaLocation kademlia ni) ns)
+                     cnt <- pred <$> readTVar setCount
+                     writeTVar setCount cnt
+                     case compare n cnt of
+                        EQ -> modifyTVar' setNodes (IntMap.delete n)
+                        LT -> do lastnode <- (IntMap.! cnt) <$> readTVar setNodes
+                                 modifyTVar' setNodes
+                                             (IntMap.insert n lastnode . IntMap.delete cnt)
+                                 modifyTVar' setIDs
+                                             (HashMap.delete (kademliaLocation kademlia ni)
+                                                              . HashMap.insert (kademliaLocation kademlia lastnode) n)
+                        GT -> writeTChan (routeLog or) $ "BUG!! Trampoline maps are out of sync."
+                     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
+
+nodeClass :: NodeInfo -> IPClass
+nodeClass = ipClass . nodeAddr
+
+ipClass :: SockAddr -> IPClass
+ipClass= either ipClass' ipClass' . either4or6
+
+ipClass' :: SockAddr -> IPClass
+ipClass' (SockAddrInet _ addr)                = IPClass (fromBE32 addr .&. 0xFF000000)
+ipClass' (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
+ipClass' _                                    = IPClass 0 -- unreachable.
+
+requestTCPMode :: OnionRouter -> Maybe Bool -> IO Bool
+requestTCPMode or wanted_mode = atomically $ requestTCPModeSTM or wanted_mode
+
+requestTCPModeSTM :: OnionRouter -> Maybe Bool -> STM Bool
+requestTCPModeSTM or wanted_mode = do
+    m <- readTVar (tcpMode or)
+    case m of
+        Nothing -> return False
+        Just oldmode -> case wanted_mode of
+            Just newmode -> do
+                writeTVar (tcpMode or) (Just newmode)
+                return newmode
+            Nothing -> return oldmode
diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs
index 4f97bfbf..fef8e8bb 100644
--- a/dht/src/Network/Tox/Transport.hs
+++ b/dht/src/Network/Tox/Transport.hs
@@ -14,7 +14,7 @@ import Data.Tox.Relay as TCP
 import Network.Tox.DHT.Transport as UDP
 import Network.Tox.Onion.Transport
 import Network.Tox.Crypto.Transport
-import OnionRouter
+import Network.Tox.Onion.Routes
 
 import Network.Socket