path: root/dht/src/Network/Tox/DHT/Handlers.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE TupleSections              #-}
module Network.Tox.DHT.Handlers where

import Control.TriadCommittee
import Crypto.Tox
import qualified Data.Tox.DHT.Multi       as Multi
import qualified Data.Wrapper.PSQInt      as Int
import Debug.Trace
import DebugTag
import DPut
import Network.Address                    (WantIP (..), fromSockAddr, ipFamily,
                                           sockAddrPort)
import Network.Kademlia
import Network.Kademlia.Bootstrap
import qualified Network.Kademlia.Routing as R
import Network.Kademlia.Search
import qualified Network.QueryResponse    as QR (Client)
         ;import Network.QueryResponse    as QR hiding (Client)
import Network.Tox.DHT.Transport          as DHTTransport
import Network.Tox.TCP.NodeId             as TCP (fromUDPNode, udpNodeInfo)
import System.Global6

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.Dependent.Sum ((==>))
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 Multi.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 -> Multi.NodeInfo -- 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 TransactionId
    , refresher6      :: BucketRefresher NodeId NodeInfo TransactionId
    , 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

nullTransactionId :: TransactionId
nullTransactionId = TransactionId (Nonce8 0) (Nonce24 zeros24)

nullSearch :: Search NodeId (IP, PortNumber) tok NodeInfo r TransactionId
nullSearch = Search
    { searchSpace       = toxSpace
    , searchNodeAddress = nodeIP &&& nodePort
    , searchQuery       = \_ _ f -> f nullTransactionId Canceled >> return nullTransactionId
    , searchQueryCancel = \_ _ -> return ()
    , searchAlpha       = 1
    , searchK           = 2
    }


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
        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) (pingUDP 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 :: Multi.NodeInfo -> Maybe WantIP -> WantIP
prefer4or6 addr iptyp = fromMaybe fallback iptyp
 where
    fallback = case Multi.udpNode addr of
        Just ni -> ipFamily $ nodeIP ni
        Nothing -> Want_Both


pingH :: ni -> Ping -> IO Pong
pingH _ Ping = return Pong

getNodesH :: Routing -> Multi.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 <$> Multi.udpNode addr of
            Just Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
            Just 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
           $ map fromUDPNode
           $ 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 -> Multi.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 $ Multi.nodeId ni -- transportPublic crypto
            }
        edta = encryptSymmetric sym n24 dta
    return $ Cookie n24 edta

createCookieSTM :: POSIXTime -> TransportCrypto -> Multi.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 $ Multi.nodeId ni -- transportPublic crypto
            }
        edta = encryptSymmetric sym n24 dta
    return $ Cookie n24 edta

cookieRequestH :: TransportCrypto -> Multi.NodeInfo -> CookieRequest -> IO (Cookie Encrypted)
cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
    dput XNetCrypto $ unlines
        [ show ni ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey)
        , show ni ++ " -->                        sender=" ++ show (Multi.nodeId ni) ]
    x <- createCookie crypto ni remoteUserKey
    dput XNetCrypto $ show ni ++ " <-- cookie " ++ show (key2id remoteUserKey)
    return x

lanDiscoveryH :: Client -> Multi.NodeInfo -> Multi.NodeInfo -> IO (Maybe (Message -> Message))
lanDiscoveryH client _ ni = do
    forM_ (Multi.udpNode ni) $ \uni -> do
        dput XLan $ show (nodeAddr uni) ++ " --> LanAnnounce " ++ show (nodeId uni)
        forkIO $ do
            myThreadId >>= flip labelThread "lan-discover-ping"
            pingUDP client uni
            return ()
    return Nothing

type Message = DHTMessage ((,) Nonce8)

type Client = QR.Client String PacketKind TransactionId Multi.NodeInfo Message


wrapAsymm :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> (Nonce8 -> dta) -> Asymm dta
wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
    { senderKey = id2key $ Multi.nodeId src
    , asymmNonce = n24
    , asymmData = dta n8
    }

serializer :: PacketKind
                -> (Asymm (Nonce8,ping) -> Message)
                -> (Message -> Maybe (Asymm (Nonce8,pong)))
                -> MethodSerializer TransactionId Multi.NodeInfo Message PacketKind ping (Maybe pong)
serializer pktkind mkping mkpong = MethodSerializer
        { methodTimeout  = \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

pingUDP :: Client -> NodeInfo -> IO Bool
pingUDP client ni = ping client (Multi.UDP ==> ni)

ping :: Client -> Multi.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 $ resultToMaybe 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 -> Multi.NodeInfo -> IO (Maybe (Cookie Encrypted))
cookieRequest crypto client localUserKey addr = do
    let (runfirst,runlast) = case Multi.udpNode addr of
            Just ni -> let sockAddr = nodeAddr ni
                           nid = id2key $ nodeId ni
                        in ( atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
                           , atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid )
            Nothing -> (return (), return ())
        cookieSerializer
            = MethodSerializer
                   { methodTimeout  = \addr -> return (addr, 5000000)
                   , method    = CookieRequestType
                   , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
                   , unwrapResponse = fmap snd . unCookie
                   }
        cookieRequest = CookieRequest localUserKey
    runfirst
    dput XNetCrypto $ show addr ++ " <-- cookieRequest"
    reply <- QR.sendQuery client cookieSerializer cookieRequest addr
    runlast
    dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply
    return $ join $ resultToMaybe 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

-- XXX: map udpNodeInfo is probably not right
unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ())

getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> Multi.NodeInfo
                   -> IO (QR.Result ([NodeInfo],[NodeInfo],Maybe ()))
getNodes client cbvar nid addr = do
    -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid
    reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
    -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply
    forM_ (join $ resultToMaybe reply) $ \(SendNodes ns) ->
        forM_ ns $ \n -> do
            now <- getPOSIXTime
            atomically $ do
                mcbs <- HashMap.lookup (nodeId . udpNodeInfo $ n) <$> readTVar cbvar
                forM_ mcbs $ \cbs -> do
                    forM_ cbs $ \cb -> do
                        rumoredAddress cb now addr (udpNodeInfo n)
    return $ case reply of
        Success x -> maybe Canceled (Success . unwrapNodes) x
        _         -> fmap (error "Network.Tox.DHT.Handlers.getNodes: the impossible happened!") reply

getNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo 
                      -> IO (QR.Result ([NodeInfo],[NodeInfo],Maybe ()))
getNodesUDP client cbvar nid addr = getNodes client cbvar nid (Multi.UDP ==> addr)

asyncGetNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> Multi.NodeInfo
                   -> (TransactionId -> QR.Result ([NodeInfo],[NodeInfo],Maybe ()) -> IO ())
                   -> IO TransactionId
asyncGetNodes client cbvar nid addr withResult = do
    QR.asyncQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr $
        \qid reply -> do
            forM_ (join $ resultToMaybe reply) $ \(SendNodes ns) ->
                forM_ ns $ \n -> do
                    now <- getPOSIXTime
                    atomically $ do
                        mcbs <- HashMap.lookup (nodeId . udpNodeInfo $ n) <$> readTVar cbvar
                        forM_ mcbs $ \cbs -> do
                            forM_ cbs $ \cb -> do
                                rumoredAddress cb now addr (udpNodeInfo n)
            withResult qid $ case reply of
                Success x -> maybe Canceled (Success . unwrapNodes) x
                _         -> fmap (error "Network.Tox.DHT.Handlers.getNodes: the impossible happened!") reply

asyncGetNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo
                      -> (TransactionId -> QR.Result ([NodeInfo],[NodeInfo],Maybe ()) -> IO ())
                      -> IO TransactionId
asyncGetNodesUDP client cbvar nid addr go = asyncGetNodes client cbvar nid (Multi.UDP ==> addr) go


updateRouting :: Client -> Routing
                        -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
                        -> Multi.NodeInfo
                        -> Message
                        -> IO ()
updateRouting client routing orouter naddr0 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                      = forM_ (Multi.udpNode naddr0) $ \naddr -> 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
    updateTable client routing orouter naddr

updateTable :: Client -> Routing
                      -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
                      -> NodeInfo
                      -> IO ()
updateTable client routing orouter naddr = do
    case prefer4or6 (Multi.UDP ==> naddr) Nothing of
        Want_IP4 -> go (committee4 routing) (refresher4 routing)
        Want_IP6 -> go (committee6 routing) (refresher6 routing)
        Want_Both -> do dput XMisc "BUG:unreachable"
                        error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
 where
    go :: TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo TransactionId -> IO ()
    go 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 orouter committee refresher) naddr

toxKademlia :: Client
                -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
                -> TriadCommittee NodeId SockAddr
                -> BucketRefresher NodeId NodeInfo TransactionId
                -> Kademlia NodeId NodeInfo
toxKademlia client orouter committee refresher
    = Kademlia quietInsertions
               toxSpace
               (vanillaIO (refreshBuckets refresher) $ pingUDP 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 Multi.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 -> Multi.NodeInfo -> Multi.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 -> Multi.NodeInfo -> Multi.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 -> ni -> ni -> 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 :: Multi.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 TransactionId
nodeSearch client cbvar = Search
    { searchSpace       = toxSpace
    , searchNodeAddress = nodeIP &&& nodePort
    , searchQuery       = asyncGetNodesUDP client cbvar
    , searchQueryCancel = cancelQuery client
    , searchAlpha       = 8
    , searchK           = 16
    }

{-
nodeSearchMulti :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () Multi.NodeInfo Multi.NodeInfo
nodeSearchMulti client cbvar = Search
    { searchSpace       = toxSpace
    , searchNodeAddress = nodeIP &&& nodePort
    -- searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok)))
    --                       (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ())
    , searchQuery       = Left $ \nid ni -> fmap fixupUDP <$> getNodes client cbvar nid ni
    , searchAlpha       = 8
    , searchK           = 16
    }
    where fixupUDP (xs,ys,m) = (map (Multi.UDP ==>) xs, map (Multi.UDP ==>) ys, m)
-}