Factor out some new libraries

	word64-map:
		Data.Word64Map
	network-addr:
		Network.Address
	tox-crypto:
		Crypto.Tox
	lifted-concurrent:
		Control.Concurrent.Lifted.Instrument
		Control.Concurrent.Async.Lifted.Instrument
	psq-wrap:
		Data.Wrapper.PSQInt
		Data.Wrapper.PSQ
	minmax-psq:
		Data.MinMaxPSQ
        tasks:
                Control.Concurrent.Tasks
	kad:
		Network.Kademlia
		Network.Kademlia.Bootstrap
		Network.Kademlia.Routing
		Network.Kademlia.CommonAPI
		Network.Kademlia.Persistence
		Network.Kademlia.Search

1 files changed, 573 insertions, 0 deletions

diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
new file mode 100644
index 00000000..1eec93b9
--- /dev/null
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -0,0 +1,573 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE TupleSections              #-}
+module Network.Tox.DHT.Handlers where
+
+import Debug.Trace
+import Network.Tox.DHT.Transport as DHTTransport
+import Network.QueryResponse as QR hiding (Client)
+import qualified Network.QueryResponse as QR (Client)
+import Crypto.Tox
+import Network.Kademlia.Search
+import qualified Data.Wrapper.PSQInt as Int
+import Network.Kademlia
+import Network.Kademlia.Bootstrap
+import Network.Address               (WantIP (..), ipFamily, fromSockAddr, sockAddrPort)
+import qualified Network.Kademlia.Routing as R
+import Control.TriadCommittee
+import System.Global6
+import DPut
+import DebugTag
+
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Base16 as Base16
+import Control.Arrow
+import Control.Monad
+import Control.Concurrent.Lifted.Instrument
+import Control.Concurrent.STM
+import Data.Hashable
+import Data.Ord
+import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
+import Network.Socket
+import qualified Data.HashMap.Strict as HashMap
+         ;import Data.HashMap.Strict (HashMap)
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+import Data.Maybe
+import Data.Serialize (Serialize)
+import Data.Word
+
+data TransactionId = TransactionId
+ { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
+ , cryptoNonce    :: Nonce24 -- ^ Used during the encryption layer.
+ }
+ deriving (Eq,Ord,Show)
+
+newtype PacketKind = PacketKind Word8
+ deriving (Eq, Ord, Serialize)
+
+pattern OnionRequest0Type = PacketKind 128 -- 0x80     Onion Request 0
+pattern OnionRequest1Type = PacketKind 129 -- 0x81     Onion Request 1
+pattern OnionRequest2Type = PacketKind 130 -- 0x82     Onion Request 2
+pattern AnnounceType  = PacketKind 131 -- 0x83     Announce Request
+pattern AnnounceResponseType = PacketKind 132 -- 0x84     Announce Response
+
+pattern DataRequestType = PacketKind 133 -- 0x85     Onion Data Request (data to route request packet)
+pattern DataResponseType = PacketKind 134 -- 0x86     Onion Data Response (data to route response packet)
+-- 0x8c     Onion Response 3
+-- 0x8d     Onion Response 2
+pattern OnionResponse3Type = PacketKind 140 -- 0x8c     Onion Response 3
+pattern OnionResponse2Type = PacketKind 141 -- 0x8d     Onion Response 2
+pattern OnionResponse1Type = PacketKind 142 -- 0x8e     Onion Response 1
+-- 0xf0     Bootstrap Info
+
+pattern DHTRequestType = PacketKind 32 -- 0x20     DHT Request
+
+pattern CookieRequestType = PacketKind 0x18
+pattern CookieResponseType = PacketKind 0x19
+
+pattern PingType      = PacketKind 0 -- 0x00     Ping Request
+pattern PongType      = PacketKind 1 -- 0x01     Ping Response
+pattern GetNodesType  = PacketKind 2 -- 0x02     Nodes Request
+pattern SendNodesType = PacketKind 4 -- 0x04     Nodes Response
+
+
+instance Show PacketKind where
+    showsPrec d PingType = mappend "PingType"
+    showsPrec d PongType = mappend "PongType"
+    showsPrec d GetNodesType = mappend "GetNodesType"
+    showsPrec d SendNodesType = mappend "SendNodesType"
+    showsPrec d DHTRequestType = mappend "DHTRequestType"
+    showsPrec d OnionRequest0Type = mappend "OnionRequest0Type"
+    showsPrec d OnionResponse1Type = mappend "OnionResponse1Type"
+    showsPrec d OnionResponse3Type = mappend "OnionResponse3Type"
+    showsPrec d AnnounceType = mappend "AnnounceType"
+    showsPrec d AnnounceResponseType = mappend "AnnounceResponseType"
+    showsPrec d DataRequestType = mappend "DataRequestType"
+    showsPrec d DataResponseType = mappend "DataResponseType"
+    showsPrec d CookieRequestType = mappend "CookieRequestType"
+    showsPrec d CookieResponseType = mappend "CookieResponseType"
+    showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
+
+msgType :: ( Serialize (f DHTRequest)
+           , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
+           , Serialize (f SendNodes), Serialize (f GetNodes)
+           , Serialize (f Pong), Serialize (f Ping)
+           ) => DHTMessage f -> PacketKind
+msgType msg = PacketKind $ fst $ dhtMessageType msg
+
+classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message
+classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client)
+classify client msg = fromMaybe (IsUnknown "unknown")
+                      $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg
+ where
+    go (DHTPing          {}) = IsQuery PingType
+    go (DHTGetNodes      {}) = IsQuery GetNodesType
+    go (DHTPong          {}) = IsResponse
+    go (DHTSendNodes     {}) = IsResponse
+    go (DHTCookieRequest {}) = IsQuery CookieRequestType
+    go (DHTCookie        {}) = IsResponse
+    go (DHTDHTRequest    {}) = IsQuery DHTRequestType
+
+data NodeInfoCallback = NodeInfoCallback
+    { interestingNodeId :: NodeId
+    , listenerId        :: Int
+    , observedAddress   :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId
+                                     -> STM ()
+    , rumoredAddress    :: POSIXTime -> SockAddr -- source of information
+                                     -> NodeInfo -- Address and port for interestingNodeId
+                                     -> STM ()
+    }
+
+data Routing = Routing
+    { tentativeId     :: NodeInfo
+    , committee4      :: TriadCommittee NodeId SockAddr
+    , committee6      :: TriadCommittee NodeId SockAddr
+    , refresher4      :: BucketRefresher NodeId NodeInfo
+    , refresher6      :: BucketRefresher NodeId NodeInfo
+    , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback])
+    }
+
+registerNodeCallback :: Routing -> NodeInfoCallback -> STM ()
+registerNodeCallback Routing{nodesOfInterest} cb = do
+    cbm <- readTVar nodesOfInterest
+    let ns = fromMaybe [] $ HashMap.lookup (interestingNodeId cb) cbm
+        bs = filter nonMatching ns
+                    where nonMatching n = (listenerId n /= listenerId cb)
+    writeTVar nodesOfInterest $ HashMap.insert (interestingNodeId cb)
+                                               (cb : bs)
+                                               cbm
+
+unregisterNodeCallback :: Int -> Routing -> NodeId -> STM ()
+unregisterNodeCallback callbackId Routing{nodesOfInterest} nid = do
+    cbm <- readTVar nodesOfInterest
+    let ns = fromMaybe [] $ HashMap.lookup nid cbm
+        bs = filter nonMatching ns
+                    where nonMatching n = (listenerId n /= callbackId)
+    writeTVar nodesOfInterest
+        $ if null bs
+            then HashMap.delete nid cbm
+            else HashMap.insert nid bs cbm
+
+
+sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
+
+sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
+
+routing4 :: Routing -> TVar (R.BucketList NodeInfo)
+routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+routing6 :: Routing -> TVar (R.BucketList NodeInfo)
+routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+newRouting :: SockAddr -> TransportCrypto
+                       -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change
+                       -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change
+                       -> IO (Client -> Routing)
+newRouting addr crypto update4 update6 = do
+    let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
+        tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
+        tentative_info = NodeInfo
+                { nodeId   = key2id $ transportPublic crypto
+                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
+                , nodePort = fromMaybe 0 $ sockAddrPort addr
+                }
+        tentative_info4 = tentative_info { nodeIP = tentative_ip4 }
+    tentative_info6 <-
+        maybe (tentative_info { nodeIP = tentative_ip6 })
+              (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
+            <$> case addr of
+                    SockAddrInet {} -> return Nothing
+                    _               -> global6
+    atomically $ do
+        -- We defer initializing the refreshSearch and refreshPing until we
+        -- have a client to send queries with.
+        let nullPing = const $ return False
+            nullSearch = Search
+                { searchSpace       = toxSpace
+                , searchNodeAddress = nodeIP &&& nodePort
+                , searchQuery       = Left $ \_ _ -> return Nothing
+                , searchAlpha       = 1
+                , searchK           = 2
+                }
+        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount
+        tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount
+        refresher4 <- newBucketRefresher tbl4 nullSearch nullPing
+        refresher6 <- newBucketRefresher tbl6 nullSearch nullPing
+        committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4
+        committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
+        cbvar <- newTVar HashMap.empty
+        return $ \client ->
+            -- Now we have a client, so tell the BucketRefresher how to search and ping.
+            let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r
+            in Routing { tentativeId     = tentative_info
+                       , committee4      = committee4
+                       , committee6      = committee6
+                       , refresher4      = updIO refresher4
+                       , refresher6      = updIO refresher6
+                       , nodesOfInterest = cbvar
+                       }
+
+
+-- TODO: This should cover more cases
+isLocal :: IP -> Bool
+isLocal (IPv6 ip6) = (ip6 == toEnum 0)
+isLocal (IPv4 ip4) = (ip4 == toEnum 0)
+
+isGlobal :: IP -> Bool
+isGlobal = not . isLocal
+
+prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
+prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
+
+toxSpace :: R.KademliaSpace NodeId NodeInfo
+toxSpace = R.KademliaSpace
+    { R.kademliaLocation = nodeId
+    , R.kademliaTestBit  = testNodeIdBit
+    , R.kademliaXor      = xorNodeId
+    , R.kademliaSample   = sampleNodeId
+    }
+
+
+pingH :: NodeInfo -> Ping -> IO Pong
+pingH _ Ping = return Pong
+
+getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
+getNodesH routing addr (GetNodes nid) = do
+    let preferred = prefer4or6 addr Nothing
+
+    (append4,append6) <- atomically $ do
+        ni4 <- R.thisNode <$> readTVar (routing4 routing)
+        ni6 <- R.thisNode <$> readTVar (routing6 routing)
+        return $ case ipFamily (nodeIP addr) of
+            Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
+            Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
+            _                                -> (id, id)
+    ks  <- go append4 $ routing4 routing
+    ks6 <- go append6 $ routing6 routing
+    let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
+                                      Want_IP4 -> (ks,ks6)
+                                      Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
+    return $ SendNodes
+           $ if null ns2 then ns1
+                         else take 4 (take 3 ns1 ++ ns2)
+ where
+    go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var)
+
+    k = 4
+
+createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted)
+createCookie crypto ni remoteUserKey = do
+    (n24,sym) <- atomically $ do
+        n24 <- transportNewNonce crypto
+        sym <- transportSymmetric crypto
+        return (n24,sym)
+    timestamp <- round . (* 1000000) <$> getPOSIXTime
+    let dta = encodePlain $ CookieData
+            { cookieTime  = timestamp
+            , longTermKey = remoteUserKey
+            , dhtKey      = id2key $ nodeId ni -- transportPublic crypto
+            }
+        edta = encryptSymmetric sym n24 dta
+    return $ Cookie n24 edta
+
+createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted)
+createCookieSTM now crypto ni remoteUserKey = do
+    let dmsg msg = trace msg (return ())
+    (n24,sym) <- do
+        n24 <- transportNewNonce crypto
+        sym <- transportSymmetric crypto
+        return (n24,sym)
+    let timestamp = round (now * 1000000)
+    let dta = encodePlain $ CookieData
+            { cookieTime  = timestamp
+            , longTermKey = remoteUserKey
+            , dhtKey      = id2key $ nodeId ni -- transportPublic crypto
+            }
+        edta = encryptSymmetric sym n24 dta
+    return $ Cookie n24 edta
+
+cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted)
+cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
+    dput XNetCrypto $ unlines
+        [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey)
+        , show (nodeAddr ni) ++ " -->                        sender=" ++ show (nodeId ni) ]
+    x <- createCookie crypto ni remoteUserKey
+    dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey)
+    return x
+
+lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message))
+lanDiscoveryH client _ ni = do
+    dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni)
+    forkIO $ do
+        myThreadId >>= flip labelThread "lan-discover-ping"
+        ping client ni
+        return ()
+    return Nothing
+
+type Message = DHTMessage ((,) Nonce8)
+
+type Client = QR.Client String PacketKind TransactionId NodeInfo Message
+
+
+wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta
+wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
+    { senderKey = id2key $ nodeId src
+    , asymmNonce = n24
+    , asymmData = dta n8
+    }
+
+serializer :: PacketKind
+                -> (Asymm (Nonce8,ping) -> Message)
+                -> (Message -> Maybe (Asymm (Nonce8,pong)))
+                -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
+serializer pktkind mkping mkpong = MethodSerializer
+        { methodTimeout  = \tid addr -> return (addr, 5000000)
+        , method         = pktkind
+        -- wrapQuery :: tid -> addr -> addr -> qry -> x
+        , wrapQuery      = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping)
+        -- unwrapResponse :: x -> b
+        , unwrapResponse = fmap (snd . asymmData) . mkpong
+        }
+
+
+unpong :: Message -> Maybe (Asymm (Nonce8,Pong))
+unpong (DHTPong asymm) = Just asymm
+unpong _               = Nothing
+
+ping :: Client -> NodeInfo -> IO Bool
+ping client addr = do
+    dput XPing $ show addr ++ " <-- ping"
+    reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
+    dput XPing $ show addr ++ " -pong-> " ++ show reply
+    maybe (return False) (\Pong -> return True) $ join reply
+
+
+saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
+saveCookieKey var saddr pk = do
+    cookiekeys <- readTVar var
+    case break (\(stored,_) -> stored == saddr) cookiekeys of
+        (xs,[])                               -> writeTVar var $ (saddr, (1  ,pk)) : xs
+        (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys
+        _                                     -> retry -- Wait for requests to this address
+                                                       -- under a different key to time out
+                                                       -- before we try this key.
+
+loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
+loseCookieKey var saddr pk = do
+    cookiekeys <- readTVar var
+    case break (\(stored,_) -> stored == saddr) cookiekeys of
+        (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $                     xs ++ ys
+        (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys
+        _                                     -> return () -- unreachable?
+
+
+cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted))
+cookieRequest crypto client localUserKey addr = do
+    let sockAddr = nodeAddr addr
+        nid = id2key $ nodeId addr
+        cookieSerializer
+            = MethodSerializer
+                   { methodTimeout  = \tid addr -> return (addr, 5000000)
+                   , method    = CookieRequestType
+                   , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
+                   , unwrapResponse = fmap snd . unCookie
+                   }
+        cookieRequest = CookieRequest localUserKey
+    atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
+    dput XNetCrypto $ show addr ++ " <-- cookieRequest"
+    reply <- QR.sendQuery client cookieSerializer cookieRequest addr
+    atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid
+    dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply
+    return $ join reply
+
+unCookie :: DHTMessage t -> Maybe (t (Cookie Encrypted))
+unCookie (DHTCookie n24 fcookie) = Just fcookie
+unCookie _ = Nothing
+
+unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
+unsendNodes (DHTSendNodes asymm) = Just asymm
+unsendNodes _                    = Nothing
+
+unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
+unwrapNodes (SendNodes ns) = (ns,ns,Just ())
+
+data SendableQuery x a b = SendableQuery
+    { sendableSerializer :: MethodSerializer TransactionId NodeInfo Message PacketKind a (Maybe x)
+    , sendableQuery      :: NodeId -> a
+    , sendableResult     :: Maybe (Maybe x) -> IO b
+    }
+
+sendQ :: SendableQuery x a b
+               -> QR.Client err PacketKind TransactionId NodeInfo Message
+               -> NodeId
+               -> NodeInfo
+               -> IO b
+sendQ s client nid addr = do
+    reply <- QR.sendQuery client (sendableSerializer s) (sendableQuery s nid) addr
+    sendableResult s reply
+
+asyncQ :: SendableQuery x a b
+            -> QR.Client err PacketKind TransactionId NodeInfo Message
+            -> NodeId
+            -> NodeInfo
+            -> (b -> IO ())
+            -> IO ()
+asyncQ s client nid addr go = do
+    QR.asyncQuery client (sendableSerializer s) (sendableQuery s nid) addr
+        $ sendableResult s >=> go
+
+getNodesSendable :: TVar (HashMap NodeId [NodeInfoCallback])
+                    -> NodeInfo
+                    -> SendableQuery SendNodes GetNodes (Maybe ([NodeInfo], [NodeInfo], Maybe ()))
+getNodesSendable cbvar addr = SendableQuery (serializer GetNodesType DHTGetNodes unsendNodes)
+                                            GetNodes
+                                            go
+  where
+    go reply = do
+        forM_ (join reply) $ \(SendNodes ns) ->
+            forM_ ns $ \n -> do
+                now <- getPOSIXTime
+                atomically $ do
+                    mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar
+                    forM_ mcbs $ \cbs -> do
+                        forM_ cbs $ \cb -> do
+                            rumoredAddress cb now (nodeAddr addr) n
+        return $ fmap unwrapNodes $ join reply
+
+getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getNodes client cbvar nid addr =
+    sendQ (getNodesSendable cbvar addr) client nid addr
+
+asyncGetNodes :: QR.Client err PacketKind TransactionId NodeInfo Message
+                 -> TVar (HashMap NodeId [NodeInfoCallback])
+                 -> NodeId
+                 -> NodeInfo
+                 -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ())
+                 -> IO ()
+asyncGetNodes client cbvar nid addr go =
+    asyncQ (getNodesSendable cbvar addr) client nid addr go
+
+updateRouting :: Client -> Routing
+                        -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
+                        -> NodeInfo
+                        -> Message
+                        -> IO ()
+updateRouting client routing orouter naddr msg
+    | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery
+                                       -- Ignore lan announcements until they reply to our ping.
+                                       -- We do this because the lan announce is not authenticated.
+                                       return ()
+    | otherwise                      = do
+    now <- getPOSIXTime
+    atomically $ do
+        m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing)
+        forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do
+            when (interestingNodeId == nodeId naddr)
+                $ observedAddress now naddr
+    case prefer4or6 naddr Nothing of
+        Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
+        Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing)
+        Want_Both -> do dput XMisc "BUG:unreachable"
+                        error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
+
+updateTable :: Client -> NodeInfo
+                      -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
+                      -> TriadCommittee NodeId SockAddr
+                      -> BucketRefresher NodeId NodeInfo
+                      -> IO ()
+updateTable client naddr orouter committee refresher = do
+        self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
+        -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr)
+        when (self /= naddr) $ do
+            -- TODO: IP address vote?
+            insertNode (toxKademlia client committee orouter refresher) naddr
+
+toxKademlia :: Client
+                -> TriadCommittee NodeId SockAddr
+                -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
+                -> BucketRefresher NodeId NodeInfo
+                -> Kademlia NodeId NodeInfo
+toxKademlia client committee orouter refresher
+    = Kademlia quietInsertions
+               toxSpace
+               (vanillaIO (refreshBuckets refresher) $ ping client)
+                   { tblTransition = \tr -> do
+                        io1 <- transitionCommittee committee tr
+                        io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
+                        -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr
+                        orouter (refreshBuckets refresher) tr
+                        return $ do
+                            io1 >> io2
+                            {-
+                            dput XMisc $ unwords
+                                [ show (transitionedTo tr)
+                                , show (transitioningNode tr)
+                                ]
+                            -}
+                            return ()
+                   }
+
+transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
+transitionCommittee committee (RoutingTransition ni Stranger) = do
+    delVote committee (nodeId ni)
+    return $ do
+        -- dput XMisc $ "delVote "++show (nodeId ni)
+        return ()
+transitionCommittee committee _ = return $ return ()
+
+type Handler = MethodHandler String TransactionId NodeInfo Message
+
+isPing :: (f Ping -> Ping) ->  DHTMessage f -> Either String Ping
+isPing unpack (DHTPing a) = Right $ unpack $ asymmData a
+isPing _      _           = Left "Bad ping"
+
+mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
+mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong)
+
+isGetNodes :: (f GetNodes -> GetNodes) ->  DHTMessage f -> Either String GetNodes
+isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a
+isGetNodes _      _               = Left "Bad GetNodes"
+
+mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
+mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes)
+
+isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest
+isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a
+isCookieRequest _      _                    = Left "Bad cookie request"
+
+mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8)
+mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)
+
+isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
+isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
+isDHTRequest _      _                        = Left "Bad dht relay request"
+
+dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
+dhtRequestH ni req = do
+    dput XMisc $ "Unhandled DHT Request: " ++ show req
+
+handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
+handlers _      routing PingType          = Just $ MethodHandler (isPing snd) mkPong            $ pingH
+handlers _      routing GetNodesType      = Just $ MethodHandler (isGetNodes snd) mkSendNodes   $ getNodesH routing
+handlers crypto _       CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto
+handlers _      _       DHTRequestType    = Just $ NoReply (isDHTRequest snd) $ dhtRequestH
+handlers _      _       typ               = error $ "TODO DHT handlers " ++ show typ
+
+nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
+nodeSearch client cbvar = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = Right $ asyncGetNodes client cbvar
+    , searchAlpha       = 8
+    , searchK           = 16
+
+    }