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

2 files changed, 1033 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
+
+    }
diff --git a/dht/src/Network/Tox/DHT/Transport.hs b/dht/src/Network/Tox/DHT/Transport.hs
new file mode 100644
index 00000000..b9b63165
--- /dev/null
+++ b/dht/src/Network/Tox/DHT/Transport.hs
@@ -0,0 +1,460 @@
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
+module Network.Tox.DHT.Transport
+    ( parseDHTAddr
+    , encodeDHTAddr
+    , forwardDHTRequests
+    , module Network.Tox.NodeId
+    , DHTMessage(..)
+    , Ping(..)
+    , Pong(..)
+    , GetNodes(..)
+    , SendNodes(..)
+    , DHTPublicKey(..)
+    , FriendRequest(..)
+    , NoSpam(..)
+    , CookieRequest(..)
+    , CookieResponse(..)
+    , Cookie(..)
+    , CookieData(..)
+    , DHTRequest
+    , mapMessage
+    , encrypt
+    , decrypt
+    , dhtMessageType
+    , asymNodeInfo
+    , putMessage -- Convenient for serializing DHTLanDiscovery
+    ) where
+
+import Network.Tox.NodeId
+import Crypto.Tox hiding (encrypt,decrypt)
+import qualified Crypto.Tox as ToxCrypto
+import Network.QueryResponse
+
+import Control.Applicative
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Bool
+import qualified Data.ByteString  as B
+         ;import Data.ByteString  (ByteString)
+import Data.Functor.Contravariant
+import Data.Hashable
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize             as S
+import Data.Tuple
+import Data.Word
+import GHC.Generics
+import Network.Socket
+
+type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
+type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
+
+
+data DHTMessage (f :: * -> *)
+    = DHTPing (Asymm (f Ping))
+    | DHTPong (Asymm (f Pong))
+    | DHTGetNodes (Asymm (f GetNodes))
+    | DHTSendNodes (Asymm (f SendNodes))
+    | DHTCookieRequest (Asymm (f CookieRequest))
+    | DHTCookie Nonce24 (f (Cookie Encrypted))
+    | DHTDHTRequest PublicKey (Asymm (f DHTRequest))
+    | DHTLanDiscovery NodeId
+
+deriving instance ( Show (f (Cookie Encrypted))
+                  , Show (f Ping)
+                  , Show (f Pong)
+                  , Show (f GetNodes)
+                  , Show (f SendNodes)
+                  , Show (f CookieRequest)
+                  , Show (f DHTRequest)
+                  ) => Show (DHTMessage f)
+
+mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b
+mapMessage f (DHTPing          a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTPong          a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTGetNodes      a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTSendNodes     a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTCookieRequest a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTDHTRequest  _ a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie
+mapMessage f (DHTLanDiscovery nid)     = Nothing
+
+
+instance Sized Ping where size = ConstSize 1
+instance Sized Pong where size = ConstSize 1
+
+parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr))
+parseDHTAddr crypto (msg,saddr)
+    | Just (typ,bs) <- B.uncons msg
+    , let right = return $ Right (msg,saddr)
+          left  = either (const right) (return . Left)
+    = case typ of
+    0x00 -> left $ direct bs saddr DHTPing
+    0x01 -> left $ direct bs saddr DHTPong
+    0x02 -> left $ direct bs saddr DHTGetNodes
+    0x04 -> left $ direct bs saddr DHTSendNodes
+    0x18 -> left $ direct bs saddr DHTCookieRequest
+    0x19 -> do
+        cs <- atomically $ readTVar (pendingCookies crypto)
+        let ni = fromMaybe (noReplyAddr saddr) $ do
+                    (cnt,key) <- lookup saddr cs <|> listToMaybe (map snd cs)
+                    either (const Nothing) Just $ nodeInfo (key2id key) saddr
+        left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni)
+    0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
+    0x21 -> left $ do
+               nid <- runGet get bs
+               ni <- nodeInfo nid saddr
+               return (DHTLanDiscovery nid, ni)
+    _ -> right
+
+encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr)
+encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni)
+
+dhtMessageType :: ( Serialize (f DHTRequest)
+                  , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
+                  , Serialize (f SendNodes), Serialize (f GetNodes)
+                  , Serialize (f Pong), Serialize (f Ping)
+                  ) => DHTMessage f -> (Word8, Put)
+dhtMessageType (DHTPing           a) = (0x00, putAsymm a)
+dhtMessageType (DHTPong           a) = (0x01, putAsymm a)
+dhtMessageType (DHTGetNodes       a) = (0x02, putAsymm a)
+dhtMessageType (DHTSendNodes      a) = (0x04, putAsymm a)
+dhtMessageType (DHTCookieRequest  a) = (0x18, putAsymm a)
+dhtMessageType (DHTCookie       n x) = (0x19, put n >> put x)
+dhtMessageType (DHTDHTRequest   k a) = (0x20, putPublicKey k >> putAsymm a)
+dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid)
+
+putMessage :: DHTMessage Encrypted8 -> Put
+putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p
+
+getCookie :: Get (Nonce24, Encrypted8 (Cookie Encrypted))
+getCookie = get
+
+getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest))
+getDHTReqest = (,) <$> getPublicKey <*> getAsymm
+
+-- ## DHT Request packets
+--
+-- | Length | Contents                  |
+-- |:-------|:--------------------------|
+-- | `1`    | `uint8_t` (0x20)          |
+-- | `32`   | receiver's DHT public key |
+--   ...      ...
+
+
+getDHT :: Sized a => Get (Asymm (Encrypted8 a))
+getDHT = getAsymm
+
+
+-- Throws an error if called with a non-internet socket.
+direct :: Sized a => ByteString
+                  -> SockAddr
+                  -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8)
+                  -> Either String (DHTMessage Encrypted8, NodeInfo)
+direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
+
+-- Throws an error if called with a non-internet socket.
+asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo
+asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr
+
+
+fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
+fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
+
+-- Throws an error if called with a non-internet socket.
+noReplyAddr :: SockAddr -> NodeInfo
+noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
+
+
+data DHTRequest
+    -- #### NAT ping request
+    --
+    --   Length   Contents
+    --  :------- :-------------------------
+    --   `1`      `uint8_t` (0xfe)
+    --   `1`      `uint8_t` (0x00)
+    --   `8`      `uint64_t` random number
+    = NATPing Nonce8
+    -- #### NAT ping response
+    --
+    --   Length   Contents
+    --  :------- :-----------------------------------------------------------------
+    --   `1`      `uint8_t` (0xfe)
+    --   `1`      `uint8_t` (0x01)
+    --   `8`      `uint64_t` random number (the same that was received in request)
+    | NATPong Nonce8
+    | DHTPK LongTermKeyWrap
+    -- From docs/Hardening_docs.txt
+    --
+    -- All hardening requests must contain exactly 384 bytes of data. (The data sent
+    -- must be padded with zeros if it is smaller than that.)
+    --
+    -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to
+    -- test.)][client_id(32 bytes) the id to query the node with.][padding]
+    --
+    -- packet id: CRYPTO_PACKET_HARDENING (48)
+    | Hardening -- TODO
+ deriving Show
+
+instance Sized DHTRequest where
+    size = VarSize $ \case
+        NATPing   _ -> 10
+        NATPong   _ -> 10
+        DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-}
+                        + case size of
+                            ConstSize n -> n
+                            VarSize f -> f (wrapData wrap)
+        Hardening -> 1{-typ-} + 384
+
+instance Serialize DHTRequest where
+    get = do
+        tag <- get
+        case tag :: Word8 of
+            0xfe -> do
+                direction <- get
+                bool NATPong NATPing (direction==(0::Word8)) <$> get
+            0x9c -> DHTPK <$> get
+            0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING
+            _ -> fail ("unrecognized DHT request: "++show tag)
+    put (NATPing n) = put (0xfe00 :: Word16) >> put n
+    put (NATPong n) = put (0xfe01 :: Word16) >> put n
+    put (DHTPK pk)  = put (0x9c :: Word8) >> put pk
+    put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO
+
+-- DHT public key packet:
+-- (As Onion data packet?)
+--
+-- | Length      | Contents                            |
+-- |:------------|:------------------------------------|
+-- | `1`         | `uint8_t` (0x9c)                    |
+-- | `8`         | `uint64_t` `no_replay`              |
+-- | `32`        | Our DHT public key                  |
+-- | `[39, 204]` | Maximum of 4 nodes in packed format |
+data DHTPublicKey = DHTPublicKey
+    { dhtpkNonce :: Word64    -- ^ The `no_replay` number is protection if
+                              -- someone tries to replay an older packet and
+                              -- should be set to an always increasing number.
+                              -- It is 8 bytes so you should set a high
+                              -- resolution monotonic time as the value.
+    , dhtpk      :: PublicKey -- dht public key
+    , dhtpkNodes :: SendNodes -- other reachable nodes
+    }
+ deriving (Eq, Show)
+
+
+-- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto)
+-- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes]
+data FriendRequest = FriendRequest
+    { friendNoSpam      :: Word32
+    , friendRequestText :: ByteString -- UTF8
+    }
+ deriving (Eq, Ord, Show)
+
+
+-- When sent as a DHT request packet (this is the data sent in the DHT request
+-- packet):
+--
+--   Length     Contents
+--  :--------- :-------------------------------
+--   `1`        `uint8_t` (0x9c)
+--   `32`       Long term public key of sender
+--   `24`       Nonce
+--   variable   Encrypted payload
+data LongTermKeyWrap = LongTermKeyWrap
+    { wrapLongTermKey :: PublicKey
+    , wrapNonce       :: Nonce24
+    , wrapData        :: Encrypted DHTPublicKey
+    }
+ deriving Show
+
+instance Serialize LongTermKeyWrap where
+    get = LongTermKeyWrap <$> getPublicKey <*> get <*> get
+    put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta
+
+
+instance Sized DHTPublicKey where
+    -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size.
+    -- WARNING: Serialize instance does not include this byte FIXME
+    size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of
+                                                    ConstSize nodes -> nodes
+                                                    VarSize sznodes -> sznodes nodes
+
+instance Sized Word32 where size = ConstSize 4
+
+-- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte
+-- where the DHTPublicKey type does include its tag.
+instance Sized FriendRequest where
+    size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length)
+
+instance Serialize DHTPublicKey where
+    -- TODO: This should agree with Sized instance.
+    get = DHTPublicKey <$> get <*> getPublicKey <*> get
+    put (DHTPublicKey nonce key nodes) = do
+        put nonce
+        putPublicKey key
+        put nodes
+
+instance Serialize FriendRequest where
+    get = FriendRequest <$> get <*> (remaining >>= getBytes)
+    put (FriendRequest nospam txt) = put nospam >> putByteString txt
+
+newtype GetNodes = GetNodes NodeId
+    deriving (Eq,Ord,Show,Read,S.Serialize)
+
+instance Sized GetNodes where
+    size = ConstSize 32 -- TODO This right?
+
+newtype SendNodes = SendNodes [NodeInfo]
+    deriving (Eq,Ord,Show,Read)
+
+instance Sized SendNodes where
+    size = VarSize $ \(SendNodes ns) -> case size of
+            ConstSize nodeFormatSize -> nodeFormatSize * length ns
+            VarSize   nsize          -> sum $ map nsize ns
+
+instance S.Serialize SendNodes where
+    get = do
+        cnt <- S.get :: S.Get Word8
+        ns <- sequence $ replicate (fromIntegral cnt) S.get
+        return $ SendNodes ns
+
+    put (SendNodes ns) = do
+        let ns' = take 4 ns
+        S.put (fromIntegral (length ns') :: Word8)
+        mapM_ S.put ns'
+
+data Ping = Ping deriving Show
+data Pong = Pong deriving Show
+
+instance S.Serialize Ping where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 0
+                then fail "Malformed ping."
+                else return Ping
+    put Ping = S.put (0 :: Word8)
+
+instance S.Serialize Pong where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 1
+                then fail "Malformed pong."
+                else return Pong
+    put Pong = S.put (1 :: Word8)
+
+newtype CookieRequest = CookieRequest PublicKey
+ deriving (Eq, Show)
+newtype CookieResponse = CookieResponse (Cookie Encrypted)
+ deriving (Eq, Show)
+
+data Cookie (f :: * -> *) = Cookie Nonce24 (f CookieData)
+
+deriving instance Eq   (f CookieData) => Eq   (Cookie f)
+deriving instance Ord  (f CookieData) => Ord  (Cookie f)
+deriving instance Show (f CookieData) => Show (Cookie f)
+deriving instance Generic (f CookieData) => Generic (Cookie f)
+
+instance Hashable (Cookie Encrypted)
+
+instance Sized (Cookie Encrypted) where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
+
+instance Serialize (Cookie Encrypted) where
+    get = Cookie <$> get <*> get
+    put (Cookie nonce dta) = put nonce >> put dta
+
+data CookieData = CookieData   --   16 (mac)
+    { cookieTime  :: Word64    --    8
+    , longTermKey :: PublicKey --   32
+    , dhtKey      :: PublicKey -- + 32
+    }                          -- = 88 bytes when encrypted.
+ deriving (Show, Generic)
+
+instance Sized CookieData where
+    size = ConstSize 72
+
+instance Serialize CookieData where
+    get = CookieData <$> get <*> getPublicKey <*> getPublicKey
+    put (CookieData tm userkey dhtkey) = do
+        put tm
+        putPublicKey userkey
+        putPublicKey userkey
+
+instance Sized CookieRequest where
+    size = ConstSize 64 -- 32 byte key + 32 byte padding
+
+instance Serialize CookieRequest where
+    get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey
+    put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k
+
+forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
+forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
+ where
+    await' :: HandleHi a -> IO a
+    await' pass = awaitMessage dht $ \case
+        Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
+            -> do mni <- closeLookup target
+                  -- Forward the message if the target is in our close list.
+                  forM_ mni $ \ni -> sendMessage dht ni m
+                  await' pass
+        m -> pass m
+
+encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo)
+encrypt crypto msg ni = do
+    let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain
+    m <- sequenceMessage $ transcode cipher msg
+    return (m, ni)
+
+encryptMessage :: Serialize a =>
+                  TransportCrypto ->
+                  PublicKey ->
+                  Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a)
+encryptMessage crypto destKey n arg = do
+    let plain  = encodePlain $ swap $ either id asymmData arg
+    secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n
+    return $ E8 $ ToxCrypto.encrypt secret plain
+
+decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo))
+decrypt crypto msg ni = do
+    let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c
+    msg' <- sequenceMessage $ transcode decipher msg
+    return $ fmap (, ni) $ sequenceMessage msg'
+
+decryptMessage :: Serialize x =>
+                  TransportCrypto
+                  -> Nonce24
+                  -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x))
+                  -> IO ((Either String ∘ ((,) Nonce8)) x)
+decryptMessage crypto n arg = do
+    let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg
+        plain8           = Composed . fmap swap . (>>= decodePlain)
+    secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n
+    return $ plain8 $ ToxCrypto.decrypt secret e
+
+sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
+sequenceMessage (DHTPing asym)              = fmap DHTPing          $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTPong asym)              = fmap DHTPong          $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTGetNodes asym)          = fmap DHTGetNodes      $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTSendNodes asym)         = fmap DHTSendNodes     $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTCookieRequest asym)     = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTCookie n dta)           = fmap (DHTCookie n)    $ uncomposed dta
+sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTLanDiscovery nid)       = pure $ DHTLanDiscovery nid
+
+transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g
+transcode f (DHTPing asym)              = DHTPing              $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTPong asym)              = DHTPong              $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTGetNodes asym)          = DHTGetNodes          $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTSendNodes asym)         = DHTSendNodes         $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTCookieRequest asym)     = DHTCookieRequest     $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTCookie n dta)           = DHTCookie n          $ f n  $ Left dta
+transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTLanDiscovery nid)       = DHTLanDiscovery nid