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

14 files changed, 4894 insertions, 0 deletions

diff --git a/dht/src/Network/Tox/AggregateSession.hs b/dht/src/Network/Tox/AggregateSession.hs
new file mode 100644
index 00000000..8c728660
--- /dev/null
+++ b/dht/src/Network/Tox/AggregateSession.hs
@@ -0,0 +1,374 @@
+-- | This module aggregates all sessions to the same remote Tox contact into a
+-- single online/offline presence.  This allows multiple lossless links to the
+-- same identity at different addresses, or even to the same address.
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Network.Tox.AggregateSession
+    ( AggregateSession
+    , newAggregateSession
+    , aggregateStatus
+    , checkCompatible
+    , compatibleKeys
+    , AddResult(..)
+    , addSession
+    , DelResult(..)
+    , delSession
+    , closeAll
+    , awaitAny
+    , dispatchMessage
+    ) where
+
+
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMChan
+import Control.Monad
+import Data.Dependent.Sum
+import Data.Function
+import qualified Data.IntMap.Strict  as IntMap
+         ;import Data.IntMap.Strict  (IntMap)
+import Data.List
+import Data.Time.Clock.POSIX
+import System.IO.Error
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+import Connection                   (Status (..))
+import Crypto.Tox                   (PublicKey, toPublic)
+import Data.Tox.Msg
+import Data.Wrapper.PSQInt          as PSQ
+import DPut
+import DebugTag
+import Network.QueryResponse
+import Network.Tox.Crypto.Transport
+import Network.Tox.DHT.Transport    (key2id)
+import Network.Tox.NodeId           (ToxProgress (..))
+import Network.Tox.Session
+
+-- | For each component session, we track the current status.
+data SingleCon = SingleCon
+    { singleSession :: Session                   -- ^ A component session.
+    , singleStatus  :: TVar (Status ToxProgress) -- ^ Either 'AwaitingSessionPacket' or 'Established'.
+    }
+
+-- | A collection of sessions between the same local and remote identities.
+data AggregateSession = AggregateSession
+    { -- | The set of component sessions indexed by their ID.
+      contactSession     :: TVar (IntMap SingleCon)
+      -- | Each inbound packets is written to this channel with the session ID
+      -- from which it came originally.
+    , contactChannel     :: TMChan (Int,CryptoMessage)
+      -- | The set of 'Established' sessions IDs.
+    , contactEstablished :: TVar (IntMap ())
+      -- | Callback for state-change notifications.
+    , notifyState        :: AggregateSession -> Session -> Status ToxProgress -> STM ()
+    }
+
+
+-- | Create a new empty aggregate session.  The argument is a callback to
+-- receive notifications when the new session changes status.  There are three
+-- possible status values:
+--
+--   [ Dormant ] - No pending or established sessions.
+--
+--   [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are
+--                                          fully established.
+--
+--   [ Established ] - At least one session is fully established and we can
+--                     send and receive packets via this aggregate.
+--
+-- The 'Session' object is provided to the callback so that it can determine the
+-- current remote and local identities for this AggregateSession.  It may not even
+-- be Established, so do not use it to send or receive packets.
+newAggregateSession :: (AggregateSession -> Session -> Status ToxProgress -> STM ())
+                        -> STM AggregateSession
+newAggregateSession notify = do
+    vimap <- newTVar IntMap.empty
+    chan <- newTMChan
+    vemap <- newTVar IntMap.empty
+    return AggregateSession
+        { contactSession     = vimap
+        , contactChannel     = chan
+        , contactEstablished = vemap
+        , notifyState        = notify
+        }
+
+-- | Information returned from 'addSession'.  Note that a value other than
+-- 'RejectedSession' does not mean there is any 'Established' session in the
+-- Aggregate.  Sessions are in 'AwaitingSessionPacket' state until a single
+-- packet is received from the remote end.
+data AddResult = FirstSession    -- ^ Initial connection with this contact.
+               | AddedSession    -- ^ Added another connection to active session.
+               | RejectedSession -- ^ Failed to add session (wrong contact / closed session).
+
+-- | The 'keepAlive' thread juggles three scheduled tasks.
+data KeepAliveEvents = DoTimeout        -- ^ A session timed-out, close it.
+                     | DoAlive          -- ^ Send a the keep-alive becon for a session.
+                     | DoRequestMissing -- ^ Detect and request lost packets.
+                     deriving Enum
+
+-- | This call loops until the provided sesison is closed or times out.  It
+-- monitors the provided (non-empty) priority queue for scheduled tasks (see
+-- 'KeepAliveEvents') to perform for the connection.
+keepAlive :: Session -> TVar (PSQ POSIXTime) -> IO ()
+keepAlive s q = do
+    myThreadId >>= flip labelThread
+        (intercalate "." ["beacon"
+                         , take 8 $ show $ key2id $ sTheirUserKey s
+                         , show $ sSessionID s])
+
+    let -- outPrint e   = dput XNetCrypto  $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e
+        unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e
+
+        doAlive = do
+            -- outPrint $ "Beacon"
+            sendMessage (sTransport s) () (Pkt ALIVE ==> ())
+
+        doRequestMissing = do
+            (ns,nmin) <- sMissingInbound s
+            -- outPrint $ "PacketRequest " ++ show (nmin,ns)
+            sendMessage (sTransport s) () (Pkt PacketRequest ==> MissingPackets ns)
+                `catchIOError` \e -> do
+                    unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns))
+                    unexpected $ "PacketRequest: " ++ show e
+                    -- Quit thread by scheduling a timeout event.
+                    now <- getPOSIXTime
+                    atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) now
+
+        re tm again e io = do
+            io
+            atomically $ modifyTVar' q $ PSQ.insert (fromEnum e) tm
+            again
+
+        doEvent again now e = case e of
+            DoTimeout        -> do dput XNetCrypto $ "TIMEOUT: " ++ show (sSessionID s)
+                                   sClose s
+            DoAlive          -> re (now + 10) again e doAlive
+            DoRequestMissing -> re (now + 5)  again e doRequestMissing -- tox-core does this at 1 second intervals
+
+    fix $ \again -> do
+
+    now <- getPOSIXTime
+    join $ atomically $ do
+        PSQ.findMin <$> readTVar q >>= \case
+          Nothing           -> error "keepAlive: unexpected empty PSQ."
+          Just ( k :-> tm ) ->
+            return $ if now < tm then threadDelay (toMicroseconds $ tm - now) >> again
+                                 else doEvent again now (toEnum k)
+
+
+-- | This function forks two threads: the 'keepAlive' beacon-sending thread and
+-- a thread to read all packets from the provided 'Session' and forward them to
+-- 'contactChannel' for a containing 'AggregateSession'
+forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId
+forkSession c s setStatus = forkIO $ do
+    myThreadId >>= flip labelThread
+        (intercalate "." ["s"
+                         , take 8 $ show $ key2id $ sTheirUserKey s
+                         , show $ sSessionID s])
+
+    q <- atomically $ newTVar $ fromList
+            [ fromEnum DoAlive :-> 0
+            , fromEnum DoRequestMissing :-> 0
+            ]
+
+    let sendPacket :: CryptoMessage -> STM ()
+        sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg)
+
+        inPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " --> " ++ e
+
+        bump = do
+            -- inPrint $ "BUMP: " ++ show (sSessionID s)
+            now <- getPOSIXTime
+            atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) (now + 15)
+
+        onPacket body loop Nothing          = return ()
+        onPacket body loop (Just (Left e))  = inPrint e >> loop
+        onPacket body loop (Just (Right x)) = body loop x
+
+        awaitPacket body = fix $ awaitMessage (sTransport s) . onPacket body
+
+    atomically $ setStatus $ InProgress AwaitingSessionPacket
+    awaitPacket $ \_ (online,()) -> do
+        when (msgID online /= M ONLINE) $ do
+            inPrint $ "Unexpected initial packet: " ++ show (msgID online)
+        atomically $ do setStatus Established
+                        sendPacket online
+        bump
+        beacon <- forkIO $ keepAlive s q
+        awaitPacket $ \awaitNext (x,()) -> do
+            bump
+            case msgID x of
+                M ALIVE      -> return ()
+                M KillPacket -> sClose s
+                _            -> atomically $ sendPacket x
+            awaitNext
+        atomically $ setStatus Dormant
+        killThread beacon
+
+-- | Add a new session (in 'AwaitingSessionPacket' state) to the
+-- 'AggregateSession'.  If the supplied session is not compatible because it is
+-- between the wrong ToxIDs or because the AggregateSession is closed,
+-- 'RejectedSession' will be returned.  Otherwise, the operation is successful.
+--
+-- The status-change callback may be triggered by this call as the aggregate
+-- may transition from 'Dormant' (empty) to 'AwaitingSessionPacket' (at least
+-- one active session).
+addSession :: AggregateSession -> Session -> IO AddResult
+addSession c s = do
+    (result,mcon,replaced) <- atomically $ do
+        let them = sTheirUserKey s
+            me   = toPublic $ sOurKey s
+        compat <- checkCompatible me them c
+        let result = case compat of
+                        Nothing      -> FirstSession
+                        Just True    -> AddedSession
+                        Just False   -> RejectedSession
+        case result of
+            RejectedSession -> return (result,Nothing,Nothing)
+            _               -> do
+                                statvar <- newTVar Dormant
+                                imap <- readTVar (contactSession c)
+                                let con = SingleCon s statvar
+                                    s0 = IntMap.lookup (sSessionID s) imap
+                                    imap' = IntMap.insert (sSessionID s) con imap
+                                writeTVar (contactSession c) imap'
+                                return (result,Just con,s0)
+
+    mapM_ (sClose . singleSession) replaced
+    forM_ mcon $ \con ->
+        forkSession c s $ \progress -> do
+            writeTVar (singleStatus con) progress
+            emap <- readTVar (contactEstablished c)
+            emap' <- case progress of
+                Established -> do
+                    when (IntMap.null emap) $ notifyState c c s Established
+                    return $ IntMap.insert (sSessionID s) () emap
+                _ -> do
+                    let emap' = IntMap.delete (sSessionID s) emap
+                    when (IntMap.null emap' && not (IntMap.null emap)) $ do
+                        imap <- readTVar (contactSession c)
+                        notifyState c c s
+                            $ if IntMap.null imap then Dormant
+                                                  else InProgress AwaitingSessionPacket
+                    return emap'
+            writeTVar (contactEstablished c) emap'
+    return result
+
+-- | Information returned from 'delSession'.
+data DelResult = NoSession      -- ^ Contact is completely disconnected.
+               | DeletedSession -- ^ Connection removed but session remains active.
+
+-- | Close and remove the componenent session corresponding to the provided
+-- Session ID.
+--
+-- The status-change callback may be triggered as the aggregate may may
+-- transition to 'Dormant' (empty) or 'AwaitingSessionPacket' (if the last
+-- 'Established' session is closed).
+delSession :: AggregateSession -> Int -> IO DelResult
+delSession c sid = do
+    (con, r) <- atomically $ do
+        imap <- readTVar (contactSession c)
+        emap <- readTVar (contactEstablished c)
+        let emap' = IntMap.delete sid emap
+            imap' = IntMap.delete sid imap
+        case IntMap.toList emap of
+            (sid0,_):_ | IntMap.null emap'
+                       , let s = singleSession $ imap IntMap.! sid0
+                -> notifyState c c s
+                        $ if IntMap.null imap' then Dormant
+                                               else InProgress AwaitingSessionPacket
+            _   -> return ()
+        writeTVar (contactSession c) imap'
+        writeTVar (contactEstablished c) emap'
+        return ( IntMap.lookup sid imap, IntMap.null imap')
+    mapM_ (sClose . singleSession) con
+    return $ if r then NoSession
+                  else DeletedSession
+
+-- | Send a packet to one or all of the component sessions in the aggregate.
+dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID.
+                                    -> CryptoMessage -> IO ()
+dispatchMessage c msid msg = join $ atomically $ do
+    imap <- readTVar (contactSession c)
+    let go = case msid of Nothing  -> forM_ imap
+                          Just sid -> forM_ (IntMap.lookup sid imap)
+    return $ go $ \con -> sendMessage (sTransport $ singleSession con) () msg
+
+-- | Retry until:
+--
+--      * a packet arrives (with component session ID) arrives.
+--
+--      * the 'AggregateSession' is closed with 'closeAll'.
+awaitAny :: AggregateSession -> STM (Maybe (Int,CryptoMessage))
+awaitAny c = readTMChan (contactChannel c)
+
+-- | Close all connections associated with the aggregate.  No new sessions will
+-- be accepted after this, and the notify callback will be informed that we've
+-- transitioned to 'Dormant'.
+closeAll :: AggregateSession -> IO ()
+closeAll c = join $ atomically $ do
+    imap <- readTVar (contactSession c)
+    closeTMChan (contactChannel c)
+    return $ forM_ (IntMap.keys imap) $ \sid -> delSession c sid
+
+-- | Query the current status of the aggregate, there are three possible
+-- values:
+--
+--   [ Dormant ] - No pending or established sessions.
+--
+--   [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are
+--                                          fully established.
+--
+--   [ Established ] - At least one session is fully established and we can
+--                     send and receive packets via this aggregate.
+--
+aggregateStatus :: AggregateSession -> STM (Status ToxProgress)
+aggregateStatus c = do
+    isclosed <- isClosedTMChan (contactChannel c)
+    imap <- readTVar (contactSession c)
+    emap <- readTVar (contactEstablished c)
+    return $ case () of
+        _ | isclosed               -> Dormant
+          | not (IntMap.null emap) -> Established
+          | not (IntMap.null imap) -> InProgress AwaitingSessionPacket
+          | otherwise              -> Dormant
+
+-- | Query whether the supplied ToxID keys are compatible with this aggregate.
+--
+--   [ Nothing ]    Any keys would be compatible because there is not yet any
+--                  sessions in progress.
+--
+--   [ Just True ]  The supplied keys match the session in progress.
+--
+--   [ Just False ] The supplied keys are incompatible.
+checkCompatible :: PublicKey    -- ^ Local Tox key (for which we know the secret).
+                   -> PublicKey -- ^ Remote Tox key.
+                   -> AggregateSession -> STM (Maybe Bool)
+checkCompatible me them c = do
+    isclosed <- isClosedTMChan (contactChannel c)
+    imap <- readTVar (contactSession c)
+    return $ case IntMap.elems imap of
+                    _ | isclosed -> Just False -- All keys are incompatible (closed).
+                    con:_        -> Just $ sTheirUserKey (singleSession con)         == them
+                                           && toPublic (sOurKey $ singleSession con) == me
+                    []           -> Nothing
+
+-- | Returns the local and remote keys that are compatible with this aggregate.
+-- If 'Nothing' Is returned, then either no key is compatible ('closeAll' was
+-- called) or all keys are compatible because no sessions have been associated.
+compatibleKeys :: AggregateSession -> STM (Maybe (PublicKey,PublicKey))
+compatibleKeys c = do
+    isclosed <- isClosedTMChan (contactChannel c)
+    imap <- readTVar (contactSession c)
+    return $ case IntMap.elems imap of
+                    _ | isclosed -> Nothing -- none.
+                    con:_        -> Just ( toPublic (sOurKey $ singleSession con)
+                                         , sTheirUserKey (singleSession con))
+                    []           -> Nothing -- any.
diff --git a/dht/src/Network/Tox/Avahi.hs b/dht/src/Network/Tox/Avahi.hs
new file mode 100644
index 00000000..635ba656
--- /dev/null
+++ b/dht/src/Network/Tox/Avahi.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns    #-}
+module Network.Tox.Avahi
+  ( module Network.Tox.Avahi
+  , NodeInfo(..)
+  , NodeId
+  ) where
+
+import Control.Applicative
+import Data.Foldable
+import Network.Address
+import Network.Avahi
+import Network.BSD         (getHostName)
+import Network.Tox.NodeId
+import Text.Read
+
+toxServiceName :: String
+toxServiceName = "_tox_dht._udp"
+
+toxServiceDomain :: String
+toxServiceDomain = "local"
+
+(<.>) :: String -> String -> String
+a <.> b = a ++ "." ++ b
+
+toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service
+toxService hostname (fromIntegral -> port) dhtkey toxid =
+  Service {
+    serviceProtocol = PROTO_UNSPEC,
+    serviceName     = "Tox DHT @ " ++ hostname,
+    serviceType     = toxServiceName,
+    serviceDomain   = toxServiceDomain,
+    serviceHost     = if null hostname then "" else hostname <.> toxServiceDomain,
+    serviceAddress  = Nothing,
+    servicePort     = port,
+    serviceText     = maybe (show dhtkey) (show . ((,) dhtkey)) toxid
+  }
+
+announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
+announceToxServiceWithHostname  = (boobs.boobs) announce toxService
+  where boobs = ((.).(.))
+
+announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
+announceToxService a b c = do
+  h <- getHostName
+  announceToxServiceWithHostname h a b c
+
+queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO ()
+queryToxService cb =
+  browse $
+  BrowseQuery
+  { lookupProtocol    = PROTO_UNSPEC
+  , lookupServiceName = toxServiceName
+  , lookupDomain      = toxServiceDomain
+  , lookupCallback    = runCallback
+  }
+  where
+    runCallback Service {..} = do
+      let both :: Maybe (NodeId, NodeId)
+          both = readMaybe serviceText
+          nid  = (fst <$> both) <|> readMaybe serviceText
+          addr = readMaybe =<< serviceAddress
+          p    = fromIntegral servicePort
+      forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both)
diff --git a/dht/src/Network/Tox/ContactInfo.hs b/dht/src/Network/Tox/ContactInfo.hs
new file mode 100644
index 00000000..e7cb48c1
--- /dev/null
+++ b/dht/src/Network/Tox/ContactInfo.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
+module Network.Tox.ContactInfo where
+
+import Connection
+
+import Data.Time.Clock.POSIX
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.PubKey.Curve25519
+import qualified Data.HashMap.Strict as HashMap
+         ;import Data.HashMap.Strict (HashMap)
+import Data.Maybe
+import Network.Tox.DHT.Transport     as DHT
+import Network.Tox.NodeId            (id2key)
+import Network.Tox.Onion.Transport   as Onion
+import DPut
+import DebugTag
+
+newtype ContactInfo extra = ContactInfo
+      -- | Map our toxid public key to an Account record.
+    { accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra))
+    }
+
+data Account extra = Account
+    { userSecret   :: SecretKey                     -- local secret key
+    , contacts     :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
+    , accountExtra :: TVar extra
+    , eventChan    :: TChan ContactEvent
+    }
+
+data ContactEvent = OnionRouted  { contact :: PublicKey, onionRouted :: OnionData }
+                  | PolicyChange { contact :: PublicKey, policyChange :: Policy }
+                  | AddrChange   { contact :: PublicKey, addrChange :: NodeInfo }
+                  | SessionEstablished { contact :: PublicKey }
+                  | SessionTerminated  { contact :: PublicKey }
+
+data Contact = Contact
+    { contactKeyPacket     :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
+    , contactLastSeenAddr  :: TVar (Maybe (POSIXTime,NodeInfo))
+    , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest))
+    , contactPolicy        :: TVar (Maybe Connection.Policy)
+    }
+
+newContactInfo :: IO (ContactInfo extra)
+newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty
+
+myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)]
+myKeyPairs (ContactInfo accounts) = do
+    acnts <- readTVar accounts
+    forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
+        return (userSecret,id2key nid)
+
+updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
+updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
+    dput XMisc "updateContactInfo!!!"
+    now <- getPOSIXTime
+    atomically $ do
+        as <- readTVar (accounts roster)
+        maybe (return ())
+              (updateAccount now remoteUserKey omsg)
+              $ HashMap.lookup (key2id localUserKey) as
+
+initContact :: STM Contact
+initContact = Contact <$> newTVar Nothing
+                      <*> newTVar Nothing
+                      <*> newTVar Nothing
+                      <*> newTVar Nothing
+
+getContact :: PublicKey -> Account extra -> STM (Maybe Contact)
+getContact remoteUserKey acc = do
+    let rkey = key2id remoteUserKey
+    cmap <- readTVar (contacts acc)
+    return $ HashMap.lookup rkey cmap
+
+updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM ()
+updateAccount' remoteUserKey acc updater = do
+    let rkey = key2id remoteUserKey
+    cmap <- readTVar (contacts acc)
+    contact <- case HashMap.lookup rkey cmap of
+        Just contact -> return contact
+        Nothing      -> do contact <- initContact
+                           writeTVar (contacts acc) $ HashMap.insert rkey contact cmap
+                           return contact
+    updater contact
+
+updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM ()
+updateAccount now remoteUserKey omsg acc = do
+    updateAccount' remoteUserKey acc $ onionUpdate now omsg
+    writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg
+
+onionUpdate :: POSIXTime -> OnionData -> Contact -> STM ()
+onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact
+                = writeTVar (contactKeyPacket contact)     $ Just (now,dhtpk)
+onionUpdate now (Onion.OnionFriendRequest fr)   contact
+                = writeTVar (contactFriendRequest contact) $ Just (now,fr)
+
+policyUpdate :: Policy -> Contact -> STM ()
+policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy
+
+addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM ()
+addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)
+
+setContactPolicy :: PublicKey -> Policy -> Account extra -> STM ()
+setContactPolicy remoteUserKey policy acc = do
+    updateAccount' remoteUserKey acc $ policyUpdate policy
+    writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy
+
+setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM ()
+setContactAddr now remoteUserKey addr acc = do
+    contact <- getContact remoteUserKey acc
+    let update = updateAccount' remoteUserKey acc $ addrUpdate now addr
+    let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
+    join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case
+      Just (_, a) | addr == a    -> update -- updates time only
+      Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old
+      Nothing                    -> update >> notify -- or if we don't have any
+      _                          -> return () -- otherwise just wait
+
+setEstablished :: PublicKey -> Account extra -> STM ()
+setEstablished remoteUserKey acc =
+    writeTChan (eventChan acc) $ SessionEstablished remoteUserKey
+
+setTerminated :: PublicKey -> Account extra -> STM ()
+setTerminated remoteUserKey acc =
+    writeTChan (eventChan acc) $ SessionTerminated remoteUserKey
+
+
+addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM ()
+addContactInfo (ContactInfo as) sk extra = do
+    a <- newAccount sk extra
+    modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
+
+delContactInfo :: ContactInfo extra -> PublicKey -> STM ()
+delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
+
+newAccount :: SecretKey -> extra -> STM (Account extra)
+newAccount sk extra = Account sk <$> newTVar HashMap.empty
+                                 <*> newTVar extra
+                                 <*> newBroadcastTChan
+
+dnsPresentation :: ContactInfo extra -> STM String
+dnsPresentation (ContactInfo accsvar) = do
+    accs <- readTVar accsvar
+    ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
+        cs <- readTVar cvar
+        rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
+            mkpkt <- readTVar (contactKeyPacket c)
+            return $ fmap (\(_,d) -> (nid,d)) mkpkt
+        return $
+            "; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
+             ++ concatMap dnsPresentation1 (catMaybes rs)
+    return $ concat ms
+
+dnsPresentation1 :: (NodeId,DHTPublicKey) -> String
+dnsPresentation1 (nid,dk) = unlines
+    [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ]
+    ]
+
+type LocalKey = NodeId
+type RemoteKey = NodeId
+
+friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
+friendRequests (ContactInfo roster) = do
+    accs <- readTVar roster
+    forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
+        cs <- readTVar cvar
+        rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
+            mfr <- readTVar (contactFriendRequest c)
+            return $ fmap (\(_,x) -> (nid,x)) mfr
+        return $ catMaybes rs
+
diff --git a/dht/src/Network/Tox/Crypto/Transport.hs b/dht/src/Network/Tox/Crypto/Transport.hs
new file mode 100644
index 00000000..a18b550d
--- /dev/null
+++ b/dht/src/Network/Tox/Crypto/Transport.hs
@@ -0,0 +1,1029 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE PatternSynonyms    #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections      #-}
+{-# LANGUAGE ViewPatterns       #-}
+module Network.Tox.Crypto.Transport
+    ( showCryptoMsg
+    , parseCrypto
+    , encodeCrypto
+    , unpadCryptoMsg
+    , decodeRawCryptoMsg
+    , parseHandshakes
+    , encodeHandshakes
+    , CryptoData(..)
+    , CryptoMessage(..)
+    , MessageName(..)
+    , CryptoPacket(..)
+    , HandshakeData(..)
+    , Handshake(..)
+    , PeerInfo(..)
+    , UserStatus(..)
+    , TypingStatus(..)
+    , GroupChatId(..)
+    , MessageType(..)
+    , isKillPacket, isOFFLINE
+    , KnownLossyness(..)
+    , AsWord16(..)
+    , AsWord64(..)
+    -- feild name classes
+    , HasGroupChatID(..)
+    , HasGroupNumber(..)
+    , HasPeerNumber(..)
+    , HasMessageNumber(..)
+    , HasMessageName(..)
+    , HasMessageData(..)
+    , HasName(..)
+    , HasTitle(..)
+    , HasMessage(..)
+    , HasMessageType(..)
+    -- lenses
+#ifdef USE_lens
+    , groupNumber, groupNumberToJoin, peerNumber, messageNumber
+    , messageName, messageData, name, title, message, messageType
+#endif
+    -- constructor
+    -- utils
+    , sizedN
+    , sizedAtLeastN
+    , isIndirectGrpChat
+    , fromEnum8
+    , fromEnum16
+    , toEnum8
+    , getCryptoMessage
+    , putCryptoMessage
+    ) where
+
+import Crypto.Tox
+import Data.Tox.Msg
+import Network.Tox.DHT.Transport (Cookie)
+import Network.Tox.NodeId
+import DPut
+import DebugTag
+import Data.PacketBuffer as PB
+
+import Network.Socket
+import Data.ByteArray
+import Data.Dependent.Sum
+
+import Control.Monad
+import Data.ByteString as B
+import Data.Function
+import Data.Maybe
+import Data.Monoid
+import Data.Word
+import Data.Bits
+import Crypto.Hash
+import Data.Functor.Contravariant
+import Data.Functor.Identity
+import Data.Text as T
+import Data.Text.Encoding as T
+import Data.Serialize as S
+import Control.Arrow
+import GHC.TypeNats
+
+showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
+showCryptoMsg _  msg = show msg
+
+parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
+parseCrypto (bbs,saddr) = case B.uncons bbs of
+    Just (0x1b,bs) -> case runGet get bs of
+        Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet.
+        Left  _   -> Right (bs,saddr)  -- Failed parse, strip first byte and pass it on.
+    _             -> Right (bbs,saddr) -- Type-code mismatch, pass it on.
+
+encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
+encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)
+
+parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr)
+parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt
+parseHandshakes bs                            _     = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs)
+
+encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr)
+encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr)
+
+{-
+createRequestPacket :: Word32 -> [Word32] -> CryptoMessage
+createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns)
+                                   in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r
+    where
+        ys = Prelude.map (subtract (seqno - 1)) xs
+        reduceToSums [] = []
+        reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs)
+        makeZeroes :: Word32 -> [Word32]
+    --  makeZeroes 0 = []
+        makeZeroes x
+            = let (d,m)= x `divMod` 255
+                  zeros= Prelude.replicate (fromIntegral d) 0
+                  in zeros ++ [m]
+        ns :: [Word8]
+        ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes)
+-}
+
+data Handshake (f :: * -> *) = Handshake
+    { -- The cookie is a cookie obtained by
+      -- sending a cookie request packet to the peer and getting a cookie
+      -- response packet with a cookie in it.  It may also be obtained in the
+      -- handshake packet by a peer receiving a handshake packet (Other
+      -- Cookie).
+      handshakeCookie :: Cookie f
+      -- The nonce is a nonce used to encrypt the encrypted part of the handshake
+      -- packet.
+    , handshakeNonce :: Nonce24
+      -- The encrypted part of the handshake packet is encrypted with the long
+      -- term user-keys of both peers.
+    , handshakeData :: f HandshakeData
+    }
+
+instance Serialize (Handshake Encrypted) where
+    get = Handshake <$> get <*> get <*> get
+    put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta
+
+data HandshakeData = HandshakeData
+    { baseNonce :: Nonce24
+    -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake
+    --   adding one each time, so it can double as something like an approximate packet number
+    , sessionKey :: PublicKey
+    -- ^ session public key of the peer (32 bytes)
+    -- The recipient of the handshake encrypts using this public key when sending CryptoPackets
+    , cookieHash :: Digest SHA512
+    -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part
+    --  This prevents a replay attack where a new cookie is inserted into
+    --  an old valid handshake packet
+    , otherCookie :: Cookie Encrypted
+    -- ^ Other Cookie (used by the recipient to respond to the handshake packet)
+    }
+ deriving (Eq,Ord,Show)
+
+instance Sized HandshakeData where
+    size = contramap baseNonce size
+            <> contramap (key2id . sessionKey) size
+            <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512)
+            <> contramap otherCookie size
+
+instance Serialize HandshakeData where
+    get = HandshakeData <$> get
+                        <*> getPublicKey
+                        <*> (fromJust . digestFromByteString <$> getBytes 64)
+                        <*> get
+    put (HandshakeData n k h c) = do
+        put n
+        putPublicKey k
+        putByteString (convert h)
+        put c
+
+data CryptoPacket (f :: * -> *) = CryptoPacket
+    { -- | The last 2 bytes of the nonce used to encrypt 'pktData'
+      pktNonce :: Word16
+      -- The payload is encrypted with the session key and 'baseNonce' set by
+      -- the receiver in their handshake + packet number (starting at 0, big
+      -- endian math).
+    , pktData :: f CryptoData
+    }
+
+deriving instance Show (CryptoPacket Encrypted)
+
+instance Sized CryptoData where
+    size = contramap bufferStart size
+            <> contramap bufferEnd size
+            <> contramap bufferData size
+
+instance Serialize (CryptoPacket Encrypted) where
+    get = CryptoPacket <$> get <*> get
+    put (CryptoPacket n16 dta) = put n16 >> put dta
+
+data CryptoData = CryptoData
+    { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
+      bufferStart :: Word32
+      -- | [  uint32_t packet number if lossless
+      --   , sendbuffer buffer_end  if lossy   , (big endian)]
+    , bufferEnd :: Word32
+      -- | [data] (TODO See Note [Padding])
+    , bufferData :: CryptoMessage
+    } deriving (Eq,Show)
+
+{-
+Note [Padding]
+
+TODO: The 'bufferData' field of 'CryptoData' should probably be something like
+/Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and
+pads leading zeros on outgoing packets.
+
+After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998),
+I've determined the following behavior.
+
+Incoming: All leading zero bytes are stripped until possibly the whole packet
+is consumed (in which case it is discarded).  This happens at
+toxcore/net_crypto.c:1366:handle_data_packet_core().
+
+Outgoing: The number of zeros added is:
+
+    padding_length len = (1373 - len) `mod` 8 where
+
+where /len/ is the size of the non-padded CryptoMessage.  This happens at
+toxcore/net_crypto.c:936:send_data_packet_helper()
+
+The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in
+terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size
+of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ).
+
+One effect of this is that short messages will be padded to at least 5 bytes.
+-}
+
+instance Serialize CryptoData where
+    get = do
+        ack <- get
+        seqno <- get
+        cm <- getCryptoMessage ack
+        return $ CryptoData ack seqno cm
+    put (CryptoData ack seqno dta) = do
+        put ack
+        put seqno
+        putCryptoMessage ack dta
+
+data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum)
+instance Serialize TypingStatus where
+   get = do
+        x <- get :: Get Word8
+        return (toEnum8 x)
+   put x = put (fromEnum8 x :: Word8)
+
+unpadCryptoMsg :: CryptoMessage -> CryptoMessage
+unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) =
+    let unpadded = B.dropWhile (== msgbyte Padding) bs
+    in either (const msg) id $ runGet (getCryptoMessage 0) unpadded
+unpadCryptoMsg msg = msg
+
+decodeRawCryptoMsg :: CryptoData -> CryptoMessage
+decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm
+
+instance Sized CryptoMessage where
+    size = VarSize $ \case
+        Pkt t :=> Identity x -> case sizeFor t of
+            ConstSize sz -> 1 + sz
+            VarSize   f  -> 1 + f x
+
+sizeFor :: Sized x => p x -> Size x
+sizeFor _ = size
+
+
+getCryptoMessage :: Word32 -> Get CryptoMessage
+getCryptoMessage seqno = fix $ \stripPadding -> do
+        t <- getWord8
+        case msgTag t of
+            Just (M Padding) -> stripPadding
+            Just (M msg) -> do x <- getPacket seqno
+                               return $ Pkt msg ==> x
+            Nothing      -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) --  $ Pkt Padding ==> Padded mempty
+
+putCryptoMessage :: Word32 -> CryptoMessage -> Put
+putCryptoMessage seqno (Pkt t :=> Identity x) = do
+    putWord8 (msgbyte t)
+    putPacket seqno x
+
+
+#ifdef USE_lens
+erCompat :: String -> a
+erCompat lens = error $ "Use of '" ++ lens ++ "'  lens on incompatible CryptoMessage type"
+#endif
+
+
+newtype GroupChatId = GrpId ByteString -- 33 bytes
+    deriving (Show,Eq)
+
+class HasGroupChatID x where
+    getGroupChatID :: x -> GroupChatId
+    setGroupChatID :: x -> GroupChatId -> x
+
+sizedN :: Int -> ByteString -> ByteString
+sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
+                                 else B.take n bs
+
+sizedAtLeastN :: Int -> ByteString -> ByteString
+sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
+                                        else bs
+
+{-
+instance HasGroupChatID CryptoMessage where
+    -- Get
+    getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload)
+        = let (xs,ys) = B.splitAt 1 payload'
+              payload' = sizedN 38 payload
+              in case B.unpack xs of
+                    [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number
+                    [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers
+                    _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message"
+
+    getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload))
+    getGroupChatID _ = error "getGroupChatID on non-groupchat message."
+
+    -- Set
+    setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid)
+        = let (xs,ys) = B.splitAt 1 payload'
+              payload' = sizedN 38 payload
+              in case B.unpack xs of
+                    [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number
+                    [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers
+                    _ -> msg -- unexpected condition, leave unchanged
+
+    setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid])
+    setGroupChatID _ _= error "setGroupChatID on non-groupchat message."
+-}
+
+#ifdef USE_lens
+groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x)
+groupChatID = lens getGroupChatID setGroupChatID
+#endif
+
+type GroupNumber = Word16
+type PeerNumber = Word16
+type MessageNumber = Word32
+
+class HasGroupNumber x where
+    getGroupNumber :: x -> GroupNumber
+    setGroupNumber :: x -> GroupNumber -> x
+
+{-
+instance HasGroupNumber CryptoMessage where
+    getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1
+        = let twobytes = B.take 2 xs
+              Right n = S.decode twobytes
+              in n
+    getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63
+        = let Right n = S.decode twobytes in n
+    getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes))
+        = let Right n = S.decode twobytes in n
+
+    getGroupNumber _   = error "getGroupNumber on CryptoMessage without group number field."
+
+    setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum
+        = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs)))
+    setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum
+        | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs)
+        | x == 0xC7              = UpToN xE (B.append (S.encode groupnum) xs)
+    setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field."
+-}
+
+#ifdef USE_lens
+groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x)
+groupNumber = lens getGroupNumber setGroupNumber
+#endif
+
+class HasGroupNumberToJoin x where
+    getGroupNumberToJoin :: x -> GroupNumber
+    setGroupNumberToJoin :: x -> GroupNumber -> x
+
+{-
+instance HasGroupNumberToJoin CryptoMessage where
+    getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join
+        = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local)
+              Right n = S.decode twobytes
+              in n
+    getGroupNumberToJoin _   = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field."
+    setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum 
+        = let (a,b)        = B.splitAt 2 xs
+              (twoBytes,c) = B.splitAt 2 b
+              twoBytes' = S.encode groupnum
+            in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c]))
+    setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field."
+-}
+
+#ifdef USE_lens
+groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x)
+groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin
+#endif
+
+class HasPeerNumber x where
+    getPeerNumber :: x -> PeerNumber
+    setPeerNumber :: x -> PeerNumber -> x
+
+{-
+instance HasPeerNumber CryptoMessage where
+    getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
+        = let Right n = S.decode twobytes in n
+    getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
+        = let Right n = S.decode twobytes in n
+    getPeerNumber _   = error "getPeerNumber on CryptoMessage without peer number field."
+
+    setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum 
+        = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
+    setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum 
+        = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
+    setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field."
+-}
+
+#ifdef USE_lens
+peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x)
+peerNumber = lens getPeerNumber setPeerNumber
+#endif
+
+class HasMessageNumber x where
+    getMessageNumber :: x -> MessageNumber
+    setMessageNumber :: x -> MessageNumber -> x
+
+{-
+instance HasMessageNumber CryptoMessage where
+    getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
+        = let Right n = S.decode fourbytes in n
+    getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
+        = let Right n = S.decode fourbytes in n
+    getMessageNumber _   = error "getMessageNumber on CryptoMessage without message number field."
+
+    setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum 
+        = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
+    setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum 
+        = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
+    setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field."
+-}
+
+#ifdef USE_lens
+messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
+messageNumber = lens getMessageNumber setMessageNumber
+#endif
+
+class HasMessageName x where
+    getMessageName :: x -> MessageName
+    setMessageName :: x -> MessageName -> x
+
+{-
+instance HasMessageName CryptoMessage where
+    getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
+        = let [n] = B.unpack onebyte
+              in toEnum . fromIntegral $ n
+    getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
+        = let [n] = B.unpack onebyte
+              in toEnum . fromIntegral $ n
+    getMessageName _   = error "getMessageName on CryptoMessage without message name field."
+
+    setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
+        = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
+    setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
+        = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
+    setMessageName _ _ = error "setMessageName on CryptoMessage without message name field."
+-}
+
+#ifdef USE_lens
+messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
+messageName = lens getMessageName setMessageName
+#endif
+
+data KnownLossyness = KnownLossy | KnownLossless
+    deriving (Eq,Ord,Show,Enum)
+
+data MessageType = Msg Word8
+                 | GrpMsg KnownLossyness MessageName
+    deriving (Eq,Show)
+
+class AsWord16 a where
+   toWord16 :: a -> Word16
+   fromWord16 :: Word16 -> a
+
+class AsWord64 a where
+   toWord64 :: a -> Word64
+   fromWord64 :: Word64 -> a
+
+
+fromEnum16 :: Enum a => a -> Word16
+fromEnum16 = fromIntegral . fromEnum
+
+fromEnum64 :: Enum a => a -> Word64
+fromEnum64 = fromIntegral . fromEnum
+
+
+-- MessageType, for our client keep it inside 16 bits
+-- but we should extend it to 32 or even 64 on the wire.
+-- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group
+--      (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension)
+instance AsWord16 MessageType where
+    toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
+    toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName)
+    fromWord16 x | x < 256                          = Msg (toEnum $ fromIntegral x)
+    fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
+    fromWord16 x = error "Not clear how to convert Word16 to MessageType"
+
+instance AsWord64 MessageType where
+    toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
+    toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName)
+    fromWord64 x | x < 256                          = Msg (toEnum $ fromIntegral x)
+    fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
+    fromWord64 x = error "Not clear how to convert Word64 to MessageType"
+
+#ifdef USE_lens
+word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x)
+word16  = lens toWord16 (\_ x -> fromWord16 x)
+#endif
+
+instance Ord MessageType where
+    compare (Msg x) (Msg y) = compare x y
+    compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly
+                                              in if r1==EQ then compare x y else r1
+    compare (Msg _) (GrpMsg _ _) = LT
+    compare (GrpMsg _ _) (Msg _) = GT
+
+class HasMessageType x where
+    getMessageType :: x -> MessageType
+    setMessageType :: x -> MessageType -> x
+
+{-
+instance HasMessageType CryptoMessage where
+    getMessageType (OneByte mid) = Msg mid
+    getMessageType (TwoByte mid _) = Msg mid
+    getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m)
+    getMessageType m@(UpToN LOSSY_GROUPCHAT   _) = GrpMsg KnownLossy    (getMessageName m)
+    getMessageType (UpToN mid _) = Msg mid
+
+    setMessageType (OneByte _   ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty        ) mname
+    setMessageType (TwoByte  _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
+    setMessageType (OneByte _   ) (GrpMsg KnownLossy    mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty        ) mname
+    setMessageType (TwoByte  _ x) (GrpMsg KnownLossy    mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname
+    setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
+    setMessageType (UpToN _ x) (GrpMsg KnownLossy    mname) = setMessageName (UpToN LOSSY_GROUPCHAT   x) mname
+    setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid
+    setMessageType (OneByte mid0  ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 
+    setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x 
+    setMessageType (UpToN mid0 x)   (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x)
+    setMessageType (OneByte mid0)   (Msg mid) = UpToN mid B.empty
+    setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x)
+    setMessageType (UpToN mid0 x)   (Msg mid) = UpToN mid x
+-}
+
+{-
+instance HasMessageType CryptoData where
+    getMessageType (CryptoData { bufferData })     = getMessageType bufferData
+    setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ }
+-}
+
+#ifdef USE_lens
+-- | This lens should always succeed on CryptoMessage
+messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x)
+messageType = lens getMessageType setMessageType
+#endif
+
+type MessageData = B.ByteString
+
+class HasMessageData x where
+    getMessageData :: x -> MessageData
+    setMessageData :: x -> MessageData -> x
+
+{-
+instance HasMessageData CryptoMessage where
+    getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
+    getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
+    getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos
+    -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8
+    getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title
+    getMessageData _   = error "getMessageData on CryptoMessage without message data field."
+
+    setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT
+        = UpToN xE (B.concat [bs,messagedata])
+    setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT
+        = UpToN xE (B.concat [bs,messagedata])
+    setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets
+        = UpToN xE (B.concat [bs,peerinfosOrTitle])
+    setMessageData _ _ = error "setMessageData on CryptoMessage without message data field."
+-}
+
+#ifdef USE_lens
+messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x)
+messageData = lens getMessageData setMessageData
+#endif
+
+class HasTitle x where
+    getTitle :: x -> Text
+    setTitle :: x -> Text -> x
+
+{-
+instance HasTitle CryptoMessage where
+    getTitle (UpToN xE bs)
+        | DIRECT_GROUPCHAT {-0x62-} <- xE,
+          (_,0x0a,mdata) <- splitByteAt 2 bs   = decodeUtf8 mdata
+        | isIndirectGrpChat xE,
+          let (_,nmb,mdata) = splitByteAt 8 bs
+              nm = toEnum (fromIntegral nmb),
+          GroupchatTitleChange <- nm           = decodeUtf8 mdata
+    getTitle _  = error "getTitle on CryptoMessage without title field."
+
+    setTitle (UpToN xE bs) msgdta
+        | DIRECT_GROUPCHAT {-0x62-} <- xE
+            = let (pre,_,_) = splitByteAt 2 bs
+                  nm = 0x0a
+              in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
+        | isIndirectGrpChat xE
+            = let (pre,_,_) = splitByteAt 8 bs
+                  nm = fromIntegral $ fromEnum GroupchatTitleChange
+              in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
+    setTitle _ _ = error "setTitle on CryptoMessage without title field."
+-}
+
+#ifdef USE_lens
+title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
+title = lens getTitle setTitle
+#endif
+
+class HasMessage x where
+    getMessage :: x -> Text
+    setMessage :: x -> Text -> x
+
+splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString)
+splitByteAt n bs = (fixed,w8,bs')
+ where
+    (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs
+
+{-
+instance HasMessage CryptoMessage where
+    getMessage (UpToN xE bs)
+        | MESSAGE <- xE        = T.decodeUtf8 bs
+        | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs
+    getMessage _ = error "getMessage on CryptoMessage without message field."
+
+    setMessage (UpToN xE bs) message
+        | MESSAGE <- xE
+          = UpToN xE $ T.encodeUtf8 message
+        | isIndirectGrpChat xE
+          = let (pre8,nm0,xs) = splitByteAt 8 bs
+                nm = if nm0 == 0 then 0x40 else nm0
+                prefix x = pre8 <> B.cons nm x
+            in UpToN xE $ prefix $ T.encodeUtf8 message
+    setMessage _ _ = error "setMessage on CryptoMessage without message field."
+-}
+
+#ifdef USE_lens
+message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
+message = lens getMessage setMessage
+#endif
+
+class HasName x where
+    getName :: x -> Text
+    setName :: x -> Text -> x
+
+
+{-
+instance HasName CryptoMessage where
+    -- Only MESSAGE_GROUPCHAT:NameChange has Name field
+    getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata
+    getName _   = error "getName on CryptoMessage without name field."
+
+    -- If its not NameChange, this setter will set it to NameChange
+    setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
+    setName _ _ = error "setName on CryptoMessage without name field."
+-}
+
+#ifdef USE_lens
+name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
+name = lens getTitle setTitle
+#endif
+
+data PeerInfo
+      = PeerInfo
+         { piPeerNum :: PeerNumber
+         , piUserKey :: PublicKey
+         , piDHTKey  :: PublicKey
+         , piName    :: ByteString -- byte-prefix for length
+         } deriving (Eq,Show)
+
+instance HasPeerNumber PeerInfo where
+    getPeerNumber = piPeerNum
+    setPeerNumber x n = x { piPeerNum = n }
+
+instance Serialize PeerInfo where
+    get = do
+        w16 <- get
+        ukey <- getPublicKey
+        dkey <- getPublicKey
+        w8 <- get :: Get Word8
+        PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8)
+
+    put (PeerInfo w16 ukey dkey bs) = do
+        put w16
+        putPublicKey ukey
+        putPublicKey dkey
+        let sz :: Word8
+            sz = case B.length bs of
+                    n | n <= 255  -> fromIntegral n
+                      | otherwise -> 255
+        put sz
+        putByteString $ B.take (fromIntegral sz) bs
+
+
+{-
+-- |
+-- default constructor, handy for formations such as:
+--
+-- > userStatus .~ Busy $ msg USERSTATUS
+--
+msg :: MessageID -> CryptoMessage
+msg mid | Just (True,0)  <- msgSizeParam mid = OneByte mid
+        | Just (True,1)  <- msgSizeParam mid = TwoByte mid 0
+        | Just (False,_) <- msgSizeParam mid = UpToN   mid B.empty
+        | otherwise                          = UpToN   mid B.empty
+-}
+
+{-
+leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
+leaveMsg     groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
+peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
+-}
+
+{-
+-- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as
+-- the maximum allowed size for the message Payload (message minus id)
+-- Or Nothing if unknown/unimplemented.
+msgSizeParam :: MessageID -> Maybe (Bool,Int)
+msgSizeParam ONLINE                     = Just (True ,0)
+msgSizeParam OFFLINE                    = Just (True ,0)
+msgSizeParam USERSTATUS                 = Just (True ,1)
+msgSizeParam TYPING                     = Just (True ,1)
+msgSizeParam NICKNAME                   = Just (False,128)
+msgSizeParam STATUSMESSAGE              = Just (False,1007)
+msgSizeParam MESSAGE                    = Just (False,1372)
+msgSizeParam ACTION                     = Just (False,1372)
+msgSizeParam FILE_DATA                  = Just (False,1372)-- up to 1373
+msgSizeParam FILE_SENDREQUEST           = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
+msgSizeParam FILE_CONTROL               = Just (False,7)   -- 8 bytes if seek, otherwise 4
+msgSizeParam INVITE_GROUPCHAT           = Just (False,38)
+msgSizeParam ONLINE_PACKET              = Just (True ,35)
+msgSizeParam DIRECT_GROUPCHAT  {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets
+msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
+msgSizeParam LOSSY_GROUPCHAT   {-0xC7-} = Nothing -- variable
+msgSizeParam _                          = Nothing
+-}
+
+isIndirectGrpChat :: Msg n t -> Bool
+isIndirectGrpChat MESSAGE_CONFERENCE = True
+isIndirectGrpChat LOSSY_CONFERENCE   = True
+isIndirectGrpChat _                  = False
+
+isKillPacket :: SomeMsg -> Bool
+isKillPacket (M KillPacket) = True
+isKillPacket _              = False
+
+isOFFLINE :: SomeMsg -> Bool
+isOFFLINE (M OFFLINE) = True
+isOFFLINE _           = False
+
+
+data MessageName = Ping -- 0x00
+                 | MessageName0x01
+                 | MessageName0x02
+                 | MessageName0x03
+                 | MessageName0x04
+                 | MessageName0x05
+                 | MessageName0x06
+                 | MessageName0x07
+                 | MessageName0x08
+                 | MessageName0x09
+                 | MessageName0x0a
+                 | MessageName0x0b
+                 | MessageName0x0c
+                 | MessageName0x0d
+                 | MessageName0x0e
+                 | MessageName0x0f
+                 | NewPeer  -- 0x10
+                 | KillPeer -- 0x11
+                 | MessageName0x12
+                 | MessageName0x13
+                 | MessageName0x14
+                 | MessageName0x15
+                 | MessageName0x16
+                 | MessageName0x17
+                 | MessageName0x18
+                 | MessageName0x19
+                 | MessageName0x1a
+                 | MessageName0x1b
+                 | MessageName0x1c
+                 | MessageName0x1d
+                 | MessageName0x1e
+                 | MessageName0x1f
+                 | MessageName0x20
+                 | MessageName0x21
+                 | MessageName0x22
+                 | MessageName0x23
+                 | MessageName0x24
+                 | MessageName0x25
+                 | MessageName0x26
+                 | MessageName0x27
+                 | MessageName0x28
+                 | MessageName0x29
+                 | MessageName0x2a
+                 | MessageName0x2b
+                 | MessageName0x2c
+                 | MessageName0x2d
+                 | MessageName0x2e
+                 | MessageName0x2f
+                 | NameChange -- 0x30
+                 | GroupchatTitleChange -- 0x31
+                 | MessageName0x32
+                 | MessageName0x33
+                 | MessageName0x34
+                 | MessageName0x35
+                 | MessageName0x36
+                 | MessageName0x37
+                 | MessageName0x38
+                 | MessageName0x39
+                 | MessageName0x3a
+                 | MessageName0x3b
+                 | MessageName0x3c
+                 | MessageName0x3d
+                 | MessageName0x3e
+                 | MessageName0x3f
+                 | ChatMessage -- 0x40
+                 | Action -- 0x41
+                 | MessageName0x42
+                 | MessageName0x43
+                 | MessageName0x44
+                 | MessageName0x45
+                 | MessageName0x46
+                 | MessageName0x47
+                 | MessageName0x48
+                 | MessageName0x49
+                 | MessageName0x4a
+                 | MessageName0x4b
+                 | MessageName0x4c
+                 | MessageName0x4d
+                 | MessageName0x4e
+                 | MessageName0x4f
+                 | MessageName0x50
+                 | MessageName0x51
+                 | MessageName0x52
+                 | MessageName0x53
+                 | MessageName0x54
+                 | MessageName0x55
+                 | MessageName0x56
+                 | MessageName0x57
+                 | MessageName0x58
+                 | MessageName0x59
+                 | MessageName0x5a
+                 | MessageName0x5b
+                 | MessageName0x5c
+                 | MessageName0x5d
+                 | MessageName0x5e
+                 | MessageName0x5f
+                 | MessageName0x60
+                 | MessageName0x61
+                 | MessageName0x62
+                 | MessageName0x63
+                 | MessageName0x64
+                 | MessageName0x65
+                 | MessageName0x66
+                 | MessageName0x67
+                 | MessageName0x68
+                 | MessageName0x69
+                 | MessageName0x6a
+                 | MessageName0x6b
+                 | MessageName0x6c
+                 | MessageName0x6d
+                 | MessageName0x6e
+                 | MessageName0x6f
+                 | MessageName0x70
+                 | MessageName0x71
+                 | MessageName0x72
+                 | MessageName0x73
+                 | MessageName0x74
+                 | MessageName0x75
+                 | MessageName0x76
+                 | MessageName0x77
+                 | MessageName0x78
+                 | MessageName0x79
+                 | MessageName0x7a
+                 | MessageName0x7b
+                 | MessageName0x7c
+                 | MessageName0x7d
+                 | MessageName0x7e
+                 | MessageName0x7f
+                 | MessageName0x80
+                 | MessageName0x81
+                 | MessageName0x82
+                 | MessageName0x83
+                 | MessageName0x84
+                 | MessageName0x85
+                 | MessageName0x86
+                 | MessageName0x87
+                 | MessageName0x88
+                 | MessageName0x89
+                 | MessageName0x8a
+                 | MessageName0x8b
+                 | MessageName0x8c
+                 | MessageName0x8d
+                 | MessageName0x8e
+                 | MessageName0x8f
+                 | MessageName0x90
+                 | MessageName0x91
+                 | MessageName0x92
+                 | MessageName0x93
+                 | MessageName0x94
+                 | MessageName0x95
+                 | MessageName0x96
+                 | MessageName0x97
+                 | MessageName0x98
+                 | MessageName0x99
+                 | MessageName0x9a
+                 | MessageName0x9b
+                 | MessageName0x9c
+                 | MessageName0x9d
+                 | MessageName0x9e
+                 | MessageName0x9f
+                 | MessageName0xa0
+                 | MessageName0xa1
+                 | MessageName0xa2
+                 | MessageName0xa3
+                 | MessageName0xa4
+                 | MessageName0xa5
+                 | MessageName0xa6
+                 | MessageName0xa7
+                 | MessageName0xa8
+                 | MessageName0xa9
+                 | MessageName0xaa
+                 | MessageName0xab
+                 | MessageName0xac
+                 | MessageName0xad
+                 | MessageName0xae
+                 | MessageName0xaf
+                 | MessageName0xb0
+                 | MessageName0xb1
+                 | MessageName0xb2
+                 | MessageName0xb3
+                 | MessageName0xb4
+                 | MessageName0xb5
+                 | MessageName0xb6
+                 | MessageName0xb7
+                 | MessageName0xb8
+                 | MessageName0xb9
+                 | MessageName0xba
+                 | MessageName0xbb
+                 | MessageName0xbc
+                 | MessageName0xbd
+                 | MessageName0xbe
+                 | MessageName0xbf
+                 | MessageName0xc0
+                 | MessageName0xc1
+                 | MessageName0xc2
+                 | MessageName0xc3
+                 | MessageName0xc4
+                 | MessageName0xc5
+                 | MessageName0xc6
+                 | MessageName0xc7
+                 | MessageName0xc8
+                 | MessageName0xc9
+                 | MessageName0xca
+                 | MessageName0xcb
+                 | MessageName0xcc
+                 | MessageName0xcd
+                 | MessageName0xce
+                 | MessageName0xcf
+                 | MessageName0xd0
+                 | MessageName0xd1
+                 | MessageName0xd2
+                 | MessageName0xd3
+                 | MessageName0xd4
+                 | MessageName0xd5
+                 | MessageName0xd6
+                 | MessageName0xd7
+                 | MessageName0xd8
+                 | MessageName0xd9
+                 | MessageName0xda
+                 | MessageName0xdb
+                 | MessageName0xdc
+                 | MessageName0xdd
+                 | MessageName0xde
+                 | MessageName0xdf
+                 | MessageName0xe0
+                 | MessageName0xe1
+                 | MessageName0xe2
+                 | MessageName0xe3
+                 | MessageName0xe4
+                 | MessageName0xe5
+                 | MessageName0xe6
+                 | MessageName0xe7
+                 | MessageName0xe8
+                 | MessageName0xe9
+                 | MessageName0xea
+                 | MessageName0xeb
+                 | MessageName0xec
+                 | MessageName0xed
+                 | MessageName0xee
+                 | MessageName0xef
+                 | MessageName0xf0
+                 | MessageName0xf1
+                 | MessageName0xf2
+                 | MessageName0xf3
+                 | MessageName0xf4
+                 | MessageName0xf5
+                 | MessageName0xf6
+                 | MessageName0xf7
+                 | MessageName0xf8
+                 | MessageName0xf9
+                 | MessageName0xfa
+                 | MessageName0xfb
+                 | MessageName0xfc
+                 | MessageName0xfd
+                 | MessageName0xfe
+                 | MessageName0xff
+                deriving (Show,Eq,Ord,Enum,Bounded)
+
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
diff --git a/dht/src/Network/Tox/Handshake.hs b/dht/src/Network/Tox/Handshake.hs
new file mode 100644
index 00000000..c48b7415
--- /dev/null
+++ b/dht/src/Network/Tox/Handshake.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE DeriveFunctor   #-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TupleSections   #-}
+{-# LANGUAGE TypeOperators   #-}
+module Network.Tox.Handshake where
+
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.Hash
+import Crypto.Tox
+import Data.Functor.Identity
+import Data.Time.Clock.POSIX
+import Network.Tox.Crypto.Transport
+import Network.Tox.DHT.Handlers     (createCookieSTM)
+import Network.Tox.DHT.Transport    (Cookie (..), CookieData (..))
+import Network.Tox.NodeId
+#ifdef THREAD_DEBUG
+#else
+import Control.Concurrent
+import GHC.Conc           (labelThread)
+#endif
+import DPut
+import DebugTag
+
+
+anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
+anyRight e []     f = return $ Left e
+anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)
+
+decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity))
+decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
+    (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto
+                                       <*> transportSymmetric crypto
+    let seckeys = map fst ukeys
+    now <- getPOSIXTime
+    -- dput XNetCrypto "decryptHandshake: trying the following keys:"
+    -- forM_ seckeys $ \k -> dput XNetCrypto $ "  " ++ show (key2id . toPublic $ k)
+    fmap join . sequence $ do -- Either Monad
+            cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie
+            Right $ do -- IO Monad
+            decrypted <- anyRight "missing key" seckeys $ \key -> do
+                            -- dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey =  " ++ show (key2id $ remotePubkey)
+                            -- dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 =  " ++ show nonce24
+                            secret <- lookupSharedSecret crypto key remotePubkey nonce24
+                            let step1 = decrypt secret encrypted
+                            case step1 of
+                                Left s -> do
+                                    -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
+                                    return (Left s)
+                                Right pln -> do
+                                    case decodePlain pln of
+                                        Left s -> do
+                                            -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
+                                            return (Left s)
+                                        Right x -> return (Right (key,x))
+            return $ do -- Either Monad
+            (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
+            left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15)
+            let hinit = hashInit
+                hctx = hashUpdate hinit n24
+                hctx' = hashUpdate hctx ecookie
+                digest = hashFinalize hctx'
+            left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest)
+            return ( key
+                   , hshake { handshakeCookie = Cookie n24 (pure cd)
+                            , handshakeData   = pure hsdata
+                            } )
+
+
+data HandshakeParams
+        = HParam
+            { hpTheirBaseNonce        :: Maybe Nonce24 -- ignore and generate your own
+            , hpOtherCookie           :: Cookie Encrypted
+            , hpTheirSessionKeyPublic :: Maybe PublicKey
+            , hpMySecretKey           :: SecretKey
+            , hpCookieRemotePubkey    :: PublicKey
+            , hpCookieRemoteDhtkey    :: PublicKey
+            }
+
+newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData
+newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
+    let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp
+        hinit                = hashInit
+        Cookie n24 encrypted = hpOtherCookie
+        hctx                 = hashUpdate hinit n24
+        hctx'                = hashUpdate hctx encrypted
+        digest               = hashFinalize hctx'
+    freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey
+    return HandshakeData
+                { baseNonce   = basenonce
+                , sessionKey  = mySessionPublic
+                , cookieHash  = digest
+                , otherCookie = freshCookie
+                }
+
+toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
+toHandshakeParams (key,hs)
+    = let hd = runIdentity $ handshakeData hs
+          Cookie _ cd0 = handshakeCookie hs
+          CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0
+      in HParam { hpTheirBaseNonce        = Just $ baseNonce hd
+                , hpOtherCookie           = otherCookie hd
+                , hpTheirSessionKeyPublic = Just $ sessionKey hd
+                , hpMySecretKey           = key
+                , hpCookieRemotePubkey    = remotePublicKey
+                , hpCookieRemoteDhtkey    = remoteDhtPublicKey
+                }
+
+encodeHandshake :: POSIXTime
+                   -> TransportCrypto
+                   -> SecretKey
+                   -> PublicKey
+                   -> Cookie Encrypted
+                   -> HandshakeData
+                   -> STM (Handshake Encrypted)
+encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do
+    n24 <- transportNewNonce crypto
+    state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them
+    return Handshake { handshakeCookie = otherCookie
+                     , handshakeNonce  = n24
+                     , handshakeData   = encrypt state $ encodePlain myhandshakeData
+                     }
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
new file mode 100644
index 00000000..9a9c893a
--- /dev/null
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -0,0 +1,731 @@
+{- LANGUAGE ApplicativeDo              -}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+{- LANGUAGE TypeApplications           -}
+module Network.Tox.NodeId
+    ( NodeInfo(..)
+    , NodeId
+    , nodeInfo
+    , nodeAddr
+    , zeroID
+    , key2id
+    , id2key
+    , getIP
+    , xorNodeId
+    , testNodeIdBit
+    , sampleNodeId
+    , NoSpam(..)
+    , NoSpamId(..)
+    , noSpamIdToHex
+    , parseNoSpamId
+    , nospam64
+    , nospam16
+    , verifyChecksum
+    , ToxContact(..)
+    , ToxProgress(..)
+    , parseToken32
+    , showToken32
+    ) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+#ifdef CRYPTONITE_BACKPORT
+import Crypto.Error.Types                     (CryptoFailable (..),
+                                               throwCryptoError)
+#else
+import Crypto.Error
+#endif
+
+import Crypto.PubKey.Curve25519
+import qualified Data.Aeson                   as JSON
+         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
+import Data.Bits.ByteString                   ()
+import qualified Data.ByteArray               as BA
+         ;import Data.ByteArray               as BA (ByteArrayAccess)
+import qualified Data.ByteString              as B
+         ;import Data.ByteString              (ByteString)
+import qualified Data.ByteString.Base16       as Base16
+import qualified Data.ByteString.Base64       as Base64
+import qualified Data.ByteString.Char8        as C8
+import Data.Char
+import Data.Data
+import Data.Hashable
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+import Data.List
+import Data.Maybe
+import Data.Serialize                         as S
+import Data.Word
+import Foreign.Storable
+import GHC.TypeLits
+import Network.Address                        hiding (nodePort)
+import System.IO.Unsafe                       (unsafeDupablePerformIO)
+import qualified Text.ParserCombinators.ReadP as RP
+import Text.Read hiding (get)
+import Data.Bits
+import Crypto.Tox
+import Foreign.Ptr
+import Data.Function
+import System.Endian
+import qualified Data.Text as Text
+         ;import Data.Text (Text)
+import Util (splitJID)
+
+-- | perform io for hashes that do allocation and ffi.
+-- unsafeDupablePerformIO is used when possible as the
+-- computation is pure and the output is directly linked
+-- to the input. we also do not modify anything after it has
+-- been returned to the user.
+unsafeDoIO :: IO a -> a
+#if __GLASGOW_HASKELL__ > 704
+unsafeDoIO = unsafeDupablePerformIO
+#else
+unsafeDoIO = unsafePerformIO
+#endif
+
+unpackPublicKey :: ByteArrayAccess bs => bs -> [Word64]
+unpackPublicKey bs = loop 0
+  where loop i
+            | i == (BA.length bs `div` 8) = []
+            | otherwise =
+                let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i)
+                 in v : loop (i+1)
+
+packPublicKey :: BA.ByteArray bs => [Word64] -> bs
+packPublicKey ws = BA.allocAndFreeze (8 * length ws) $
+    flip fix ws $ \loop ys ptr -> case ys of
+        [] -> return ()
+        x:xs -> do poke ptr (toBE64 x)
+                   loop xs (plusPtr ptr 8)
+{-# NOINLINE packPublicKey #-}
+
+-- We represent the node id redundantly in two formats.  The [Word64] format is
+-- convenient for short-circuiting xor/distance comparisons.  The PublicKey
+-- format is convenient for encryption.
+data NodeId = NodeId [Word64] !(Maybe PublicKey)
+ deriving Data
+
+instance Data PublicKey where
+  -- Data a => (forall d b . Data d => c (d -> b) -> d -> c b) -> (forall g . g -> c g) -> a -> c a
+  gfoldl f z txt = z (throwCryptoError . publicKey) `f` (BA.convert txt :: ByteString)
+  toConstr _     = error "Crypto.PubKey.Curve25519.toConstr"
+  gunfold _ _    = error "Crypto.PubKey.Curve25519.gunfold"
+#if MIN_VERSION_base(4,2,0)
+  dataTypeOf _   = mkNoRepType "Crypto.PubKey.Curve25519.PublicKey"
+#else
+  dataTypeOf _   = mkNorepType "Crypto.PubKey.Curve25519.PublicKey"
+#endif
+
+
+instance Eq NodeId where
+ (NodeId ws _) == (NodeId xs _)
+  =         ws == xs
+
+instance Ord NodeId where
+    compare (NodeId ws _) (NodeId xs _) = compare ws xs
+
+instance Sized NodeId where size = ConstSize 32
+
+key2id :: PublicKey -> NodeId
+key2id k = NodeId (unpackPublicKey k) (Just k)
+
+bs2id :: ByteString -> NodeId
+bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs
+
+id2key :: NodeId -> PublicKey
+id2key (NodeId ws (Just key)) = key
+id2key (NodeId key Nothing)   = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes)
+
+zeroKey :: PublicKey
+zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0
+
+zeroID :: NodeId
+zeroID = NodeId (replicate 4 0) (Just zeroKey)
+
+-- | Convert to and from a Base64 variant that uses .- instead of +/.
+nmtoken64 :: Bool -> Char -> Char
+nmtoken64 False '.' = '+'
+nmtoken64 False '-' = '/'
+nmtoken64 True  '+' = '.'
+nmtoken64 True  '/' = '-'
+nmtoken64 _     c   = c
+
+-- | Parse 43-digit base64 token into 32-byte bytestring.
+parseToken32 :: String -> Either String ByteString
+parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str)
+
+-- | Encode 32-byte bytestring as 43-digit base64 token.
+showToken32 :: ByteArrayAccess bin => bin -> String
+showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs
+
+instance Read NodeId where
+    readsPrec _ str
+        | (bs,_) <- Base16.decode (C8.pack $ take 64 str)
+        , CryptoPassed pub <- publicKey bs -- B.length bs == 32
+                    = [ (key2id pub, drop (2 * B.length bs) str) ]
+        | Right bs <- parseToken32 str
+        , CryptoPassed pub <- publicKey bs -- B.length bs == 32
+                    = [ (key2id pub, drop 43 str) ]
+        | otherwise = []
+
+instance Show NodeId where
+    show nid = showToken32 $ id2key nid
+
+instance S.Serialize NodeId where
+    get = key2id <$> getPublicKey
+    put nid = putPublicKey $ id2key nid
+
+instance Hashable NodeId where
+    hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws)
+
+testNodeIdBit :: NodeId -> Word -> Bool
+testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available.
+  | fromIntegral i < 256 -- 256 bits
+  , (q, r) <- quotRem (fromIntegral i) 64
+  = testBit (ws !! q) (63 - r)
+  |     otherwise      = False
+
+xorNodeId :: NodeId -> NodeId -> NodeId
+xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing
+
+sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
+sampleNodeId gen (NodeId self k) (q,m,b)
+    | q <= 0    = bs2id <$> gen 32
+    | q >= 32   = pure (NodeId self k)
+    | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend?
+          bw = shiftL (fromIntegral b) (8*(7-r))
+          mw = bw - 1 :: Word64
+          (hd, t0 : _) = splitAt (qw-1) self
+          h = xor bw (complement mw .&. t0)
+    = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs ->
+        let (w:ws) = unpackPublicKey bs
+        in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing
+
+data NodeInfo = NodeInfo
+  { nodeId   :: NodeId
+  , nodeIP   :: IP
+  , nodePort :: PortNumber
+  }
+ deriving (Eq,Ord)
+
+nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
+nodeInfo nid saddr
+    | Just ip <- fromSockAddr saddr
+    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
+    | otherwise                       = Left "Address family not supported."
+
+
+instance ToJSON NodeInfo where
+    toJSON (NodeInfo nid (IPv4 ip) port)
+        = JSON.object [ "public_key" .= show nid
+                      , "ipv4" .= show ip
+                      , "port" .= (fromIntegral port :: Int)
+                      ]
+    toJSON (NodeInfo nid (IPv6 ip6) port)
+        | Just ip <- un4map ip6
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv4" .= show ip
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+        | otherwise
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv6" .= show ip6
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+instance FromJSON NodeInfo where
+    parseJSON (JSON.Object v) = do
+        nidstr <- v JSON..: "public_key"
+        ip6str <- v JSON..:? "ipv6"
+        ip4str <- v JSON..:? "ipv4"
+        portnum <- v JSON..: "port"
+        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
+              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
+        let (bs,_) = Base16.decode (C8.pack nidstr)
+            enid   = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
+        idbs <- (guard (B.length bs == 32) >> return bs)
+                <|> either fail (return . B.drop 1) enid
+        return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16))
+
+getIP :: Word8 -> S.Get IP
+getIP 0x02 = IPv4 <$> S.get
+getIP 0x0a = IPv6 <$> S.get
+getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
+getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
+getIP x    = fail ("unsupported address family ("++show x++")")
+
+instance Sized NodeInfo where
+    size = VarSize $ \(NodeInfo nid ip port) ->
+            case ip of
+                IPv4 _ -> 39 -- 35 +  4 = 1 + 4 + 2 + 32
+                IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32
+
+instance S.Serialize NodeInfo where
+    get = do
+        addrfam <- S.get :: S.Get Word8
+        let fallback = do -- FIXME: Handle unrecognized address families.
+                IPv6 <$> S.get
+                return $ IPv6 (read "::" :: IPv6)
+        ip <- getIP addrfam <|> fallback
+        port <- S.get :: S.Get PortNumber
+        nid <- S.get
+        return $ NodeInfo nid ip port
+
+    put (NodeInfo nid ip port) = do
+        case ip of
+            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
+            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
+        S.put port
+        S.put nid
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+b64digit :: Char -> Bool
+b64digit '.' = True
+b64digit '+' = True
+b64digit '-' = True
+b64digit '/' = True
+b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z')
+
+ip_w_port :: Int -> RP.ReadP (IP, PortNumber)
+ip_w_port i = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+
+instance Read NodeInfo where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = 43 -- characters in node id.
+        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                      RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char])))
+        nodeidAt = do (is64,hexhash) <-
+                        fmap (True,) (sequence $ replicate n (RP.satisfy b64digit))
+                          RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit))
+                      RP.char '@' RP.+++ RP.satisfy isSpace
+                      addrstr <- parseAddr
+                      nid <- if is64
+                                then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of
+                                  Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs)
+                                  _                              -> fail "Bad node id."
+                                else case Base16.decode $ C8.pack hexhash of
+                                  (bs,rem) | B.length bs == 32 &&  B.null rem -> return (bs2id bs)
+                                  _                                           -> fail "Bad node id."
+                      return (nid,addrstr)
+    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
+    (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of
+                    [] -> fail "Bad address."
+                    ((ip,port),_):_ -> return (ip,port)
+    return $ NodeInfo nid ip port
+
+-- The Hashable instance depends only on the IP address and port number.
+--
+-- TODO: Why is the node id excluded?
+instance Hashable NodeInfo where
+  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
+  {-# INLINE hashWithSalt #-}
+
+
+instance Show NodeInfo where
+    showsPrec _ (NodeInfo nid ip port) =
+        shows nid . ('@' :) . showsip . (':' :) . shows port
+     where
+        showsip
+            | IPv4 ip4 <- ip                          = shows ip4
+            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
+            | otherwise                               = ('[' :) . shows ip . (']' :)
+
+
+
+
+{-
+type NodeId = PubKey
+
+pattern NodeId bs = PubKey bs
+
+-- TODO: This should probably be represented by Curve25519.PublicKey, but
+-- ByteString has more instances...
+newtype PubKey = PubKey ByteString
+ deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable)
+
+instance Serialize PubKey where
+    get = PubKey <$> getBytes 32
+    put (PubKey bs) = putByteString bs
+
+instance Show PubKey where
+    show (PubKey bs) = C8.unpack $ Base16.encode bs
+
+instance FiniteBits PubKey where
+    finiteBitSize _ = 256
+
+instance Read PubKey where
+    readsPrec _ str
+        | (bs, xs) <- Base16.decode $ C8.pack str
+        , B.length bs == 32
+                    = [ (PubKey bs, drop 64 str) ]
+        | otherwise = []
+
+
+
+
+data NodeInfo = NodeInfo
+  { nodeId   :: NodeId
+  , nodeIP   :: IP
+  , nodePort :: PortNumber
+  }
+ deriving (Eq,Ord,Data)
+
+instance Data PortNumber where
+    dataTypeOf _ = mkNoRepType "PortNumber"
+    toConstr _     = error "PortNumber.toConstr"
+    gunfold _ _    = error "PortNumber.gunfold"
+
+instance ToJSON NodeInfo where
+    toJSON (NodeInfo nid (IPv4 ip) port)
+        = JSON.object [ "public_key" .= show nid
+                      , "ipv4" .= show ip
+                      , "port" .= (fromIntegral port :: Int)
+                      ]
+    toJSON (NodeInfo nid (IPv6 ip6) port)
+        | Just ip <- un4map ip6
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv4" .= show ip
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+        | otherwise
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv6" .= show ip6
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+instance FromJSON NodeInfo where
+    parseJSON (JSON.Object v) = do
+        nidstr <- v JSON..: "public_key"
+        ip6str <- v JSON..:? "ipv6"
+        ip4str <- v JSON..:? "ipv4"
+        portnum <- v JSON..: "port"
+        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
+              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
+        let (bs,_) = Base16.decode (C8.pack nidstr)
+        guard (B.length bs == 32)
+        return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))
+
+getIP :: Word8 -> S.Get IP
+getIP 0x02 = IPv4 <$> S.get
+getIP 0x0a = IPv6 <$> S.get
+getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
+getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
+getIP x    = fail ("unsupported address family ("++show x++")")
+
+instance S.Serialize NodeInfo where
+    get = do
+        addrfam <- S.get :: S.Get Word8
+        ip <- getIP addrfam
+        port <- S.get :: S.Get PortNumber
+        nid <- S.get
+        return $ NodeInfo nid ip port
+
+    put (NodeInfo nid ip port) = do
+        case ip of
+            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
+            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
+        S.put port
+        S.put nid
+
+-- node format:
+-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
+-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
+-- [port (in network byte order), length=2 bytes]
+-- [char array (node_id), length=32 bytes]
+--
+
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+instance Read NodeInfo where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = 64 -- characters in node id.
+        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                      RP.+++ RP.munch (not . isSpace)
+        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
+                      RP.char '@' RP.+++ RP.satisfy isSpace
+                      addrstr <- parseAddr
+                      nid <- case Base16.decode $ C8.pack hexhash of
+                              (bs,_) | B.length bs==32 -> return (PubKey bs)
+                              _                        -> fail "Bad node id."
+                      return (nid,addrstr)
+    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
+    let raddr = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+    (ip,port) <- case RP.readP_to_S raddr addrstr of
+                    [] -> fail "Bad address."
+                    ((ip,port),_):_ -> return (ip,port)
+    return $ NodeInfo nid ip port
+
+
+-- The Hashable instance depends only on the IP address and port number.
+instance Hashable NodeInfo where
+  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
+  {-# INLINE hashWithSalt #-}
+
+
+instance Show NodeInfo where
+    showsPrec _ (NodeInfo nid ip port) =
+        shows nid . ('@' :) . showsip . (':' :) . shows port
+     where
+        showsip
+            | IPv4 ip4 <- ip                          = shows ip4
+            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
+            | otherwise                               = ('[' :) . shows ip . (']' :)
+
+nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
+nodeInfo nid saddr
+    | Just ip <- fromSockAddr saddr
+    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
+    | otherwise                       = Left "Address family not supported."
+
+zeroID :: NodeId
+zeroID = PubKey $ B.replicate 32 0
+
+-}
+
+nodeAddr :: NodeInfo -> SockAddr
+nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
+
+
+newtype ForwardPath (n::Nat) = ForwardPath ByteString
+ deriving (Eq, Ord,Data)
+
+{-
+class KnownNat n => OnionPacket n where
+    mkOnion :: ReturnPath n -> Packet -> Packet
+instance OnionPacket 0 where mkOnion _ = id
+instance OnionPacket 3 where mkOnion = OnionResponse3
+-}
+
+data NoSpam = NoSpam !Word32 !(Maybe Word16)
+ deriving (Eq,Ord,Show)
+
+instance Serialize NoSpam where
+    get = NoSpam <$> get <*> get
+    put (NoSpam w32 w16) = do
+        put w32
+        put w16
+
+-- Utilizes Data.Serialize format for Word32 nospam and Word16 checksum.
+instance Read NoSpam where
+    readsPrec d s = case break isSpace s of
+        ('$':ws    ,rs) | (length ws == 8)  -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws
+        ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws
+        _                                   -> []
+
+base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
+base64decode rs getter s =
+    either fail (\a -> return (a,rs))
+        $ runGet getter
+           =<< Base64.decode (C8.pack $ map (nmtoken64 False) s)
+
+base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
+base16decode rs getter s =
+    either fail (\a -> return (a,rs))
+        $ runGet getter
+        $ fst
+        $ Base16.decode (C8.pack s)
+
+verifyChecksum :: PublicKey -> Word16 -> Either String ()
+verifyChecksum _ _ = return () -- TODO
+
+data NoSpamId = NoSpamId NoSpam PublicKey
+ deriving (Eq,Ord)
+
+noSpamIdToHex :: NoSpamId -> String
+noSpamIdToHex (NoSpamId nspam pub) = C8.unpack (Base16.encode $ BA.convert pub)
+                                     ++ nospam16 nspam
+
+nospam16 :: NoSpam -> String
+nospam16 (NoSpam w32 Nothing) = n ++ "????"
+    where n = take 8 $ nospam16 (NoSpam w32 (Just 0))
+nospam16 (NoSpam w32 (Just w16)) = C8.unpack $ Base16.encode $ runPut $ do
+    put w32
+    put w16
+
+nospam64 :: NoSpam -> String
+nospam64 (NoSpam w32 Nothing) = n ++ "???"
+    where n = take 5 $ nospam64 (NoSpam w32 (Just 0))
+nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do
+    put w32
+    put w16
+
+instance Show NoSpamId where
+    show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox"
+
+instance Read NoSpamId where
+    readsPrec d s = either fail id $ do
+        (jid,xs) <- Right $ break isSpace s
+        nsid <- parseNoSpamId $ Text.pack jid
+        return [(nsid,xs)]
+
+parseNoSpamHex :: Text -> Either String NoSpamId
+parseNoSpamHex hex = Right $ NoSpamId (read $ "0x"++nospamsum) (id2key $ read hkey)
+ where
+    (hkey,nospamsum) = splitAt 64 $ Text.unpack hex
+
+parseNoSpamId :: Text -> Either String NoSpamId
+parseNoSpamId spec | Text.length spec == 76
+                   , Text.all isHexDigit spec = parseNoSpamHex spec
+                   | otherwise                = parseNoSpamJID spec
+
+parseNoSpamJID :: Text -> Either String NoSpamId
+parseNoSpamJID jid = do
+    (u,h) <- maybe (Left "Invalid JID.") Right
+                $ let (mu,h,_) = splitJID jid
+                  in fmap (, h) mu
+    base64 <- case splitAt 43 $ Text.unpack h of
+                (base64,".tox") -> Right base64
+                _               -> Left "Hostname should be 43 base64 digits followed by .tox."
+    pub <- id2key <$> readEither base64
+    let ustr = Text.unpack u
+    case ustr of
+        '$' : b64digits       -> solveBase64NoSpamID b64digits pub
+        '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits)
+                                    return $ NoSpamId nospam pub
+        _ -> Left "Missing nospam."
+
+solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId
+solveBase64NoSpamID b64digits pub = do
+    NoSpam nospam mx <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits
+    maybe (const $ Left "missing checksum") (flip ($)) mx $ \x -> do
+    let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
+        nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
+        sum = x `xor` nlo `xor` nhi `xor` xorsum pub
+        -- Find any question mark indices.
+        qs  = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7]
+        -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles.
+        ns  = filter (\case; (_,0) -> False; _ -> True)
+              $ zip [0..7]
+              $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum
+        -- Represent the nospam value as a Word64
+        n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64
+
+        -- q=0   1   2   3   4   5   6   7
+        -- 012 345 670 123 456 701 234 567
+        nibblePlace n q = case mod (n - 3 * q) 8 of
+                p | p < 3 -> Just (q,p)
+                _         -> Nothing
+
+        solve []         !ac = Right ac
+        solve ((n,b):ns) !ac = do
+            -- Find nibble p of question-digit q that corresponds to nibble n.
+            (q,p) <- maybe (Left "Unsolvable nospam.") Right
+                     $ foldr (<|>) Nothing $ map (nibblePlace n) qs
+            let bitpos = q * 6 + p * 2
+                ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos
+            solve ns ac'
+    n64' <- solve ns n64
+    let nospam' = fromIntegral (n64' `shiftR` 32)
+        cksum'  = fromIntegral (n64' `shiftR` 16)
+    return $ NoSpamId (NoSpam nospam' (Just cksum')) pub
+
+-- | This type indicates a roster-link relationship between a local toxid and a
+-- remote toxid.  Note that these toxids are represented as the type 'NodeId'
+-- even though they are long-term keys rather than the public keys of Tox DHT
+-- nodes.
+data ToxContact = ToxContact NodeId{-me-} NodeId{-them-}
+ deriving (Eq,Ord)
+
+instance Show ToxContact where show = show . showToxContact_
+
+showToxContact_ :: ToxContact -> String
+showToxContact_ (ToxContact me them) = show me ++ ":" ++ show them
+
+-- | This type indicates the progress of a tox encrypted friend link
+-- connection.  Two scenarios are illustrated below.  The parenthesis show the
+-- current 'G.Status' 'ToxProgress' of the session.
+--
+--
+-- Perfect handshake scenario:
+--
+--  Peer 1                                  Peer 2
+--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
+--                     Cookie request ->
+--                                       <- Cookie response
+--  (InProgress AwaitingHandshake)          (Dormant/InProgress AcquiringCookie)
+--                   Handshake packet ->
+--                                          * accepts connection
+--                                          (InProgress AwaitingSessionPacket)
+--                                       <- Handshake packet
+--  *accepts connection
+--  (InProgress AwaitingSessionPacket)
+--                   Encrypted packet -> <- Encrypted packet
+--  *confirms connection                    *confirms connection
+--  (Established)                           (Established)
+--
+--                           Connection successful.
+--
+--                  Encrypted packets -> <- Encrypted packets
+--
+--
+--
+--
+--  More realistic handshake scenario:
+--  Peer 1                                  Peer 2
+--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
+--                      Cookie request ->   *packet lost*
+--                      Cookie request ->
+--                                        <- Cookie response
+--  (InProgress AwaitingHandshake)           (Dormant/InProgress AcquiringCookie)
+--
+--                                           *Peer 2 randomly starts new connection to peer 1
+--                                           (InProgress AcquiringCookie)
+--                                        <- Cookie request
+--                     Cookie response ->
+--                                           (InProgress AwaitingHandshake)
+--
+--                    Handshake packet -> <- Handshake packet
+--  *accepts connection                      * accepts connection
+--  (InProgress AwaitingSessionPacket)      (InProgress AwaitingSessionPacket)
+--
+--                    Encrypted packet -> <- Encrypted packet
+--  *confirms connection                     *confirms connection
+--  (Established)                           (Established)
+--
+--                              Connection successful.
+--
+--                   Encrypted packets -> <- Encrypted packets
+data ToxProgress
+    = AwaitingDHTKey        -- ^ Waiting to receive their DHT key.
+    | AcquiringIPAddress    -- ^ Searching DHT to obtain their node's IP & port.
+    | AcquiringCookie       -- ^ Attempting to obtain a cookie.
+    | AwaitingHandshake     -- ^ Waiting to receive a handshake.
+    | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed".
+    deriving (Eq,Ord,Enum,Show)
+
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
new file mode 100644
index 00000000..f44dd79c
--- /dev/null
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -0,0 +1,369 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Network.Tox.Onion.Handlers where
+
+import Network.Kademlia.Search
+import Network.Tox.DHT.Transport
+import Network.Tox.DHT.Handlers hiding (Message,Client)
+import Network.Tox.Onion.Transport
+import Network.QueryResponse as QR hiding (Client)
+import qualified Network.QueryResponse as QR (Client)
+import Crypto.Tox
+import qualified Data.Wrapper.PSQ             as PSQ
+         ;import Data.Wrapper.PSQ             (PSQ,pattern (:->))
+import Control.Arrow
+
+import Data.Function
+import qualified Data.MinMaxPSQ               as MinMaxPSQ
+         ;import Data.MinMaxPSQ               (MinMaxPSQ')
+import Network.BitTorrent.DHT.Token           as Token
+
+import Control.Exception hiding (Handler)
+import Control.Monad
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent
+import GHC.Conc (labelThread)
+#endif
+import Control.Concurrent.STM
+import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
+import Network.Socket
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+import Data.Maybe
+import Data.Functor.Identity
+import DPut
+import DebugTag
+
+type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
+type Message = OnionMessage Identity
+
+classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message
+classify msg = go msg
+ where
+    go (OnionAnnounce         announce)    = IsQuery AnnounceType
+                                                $ TransactionId (snd $ runIdentity $ asymmData announce)
+                                                                (asymmNonce announce)
+    go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
+    go (OnionToRoute          {})          = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
+    go (OnionToRouteResponse  {})          = IsResponse              (TransactionId (Nonce8 0) (Nonce24 zeros24))
+
+-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
+-- some secret bytes generated when the instance is created, the current time
+-- divided by a 20 second timeout, the public key of the requester and the source
+-- ip/port that the packet was received from. Since the ip/port that the packet
+-- was received from is in the `ping_id`, the announce packets being sent with a
+-- ping id must be sent using the same path as the packet that we received the
+-- `ping_id` from or announcing will fail.
+--
+-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
+-- time (20 to 40 seconds) for a peer to announce himself while taking in count
+-- all the possible delays with some extra seconds.
+announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
+announceH routing toks keydb oaddr req = do
+    case () of
+        _ | announcePingId req == zeros32
+          -> go False
+
+        _ -> let Nonce32 bs = announcePingId req
+                 tok        = fromPaddedByteString 32 bs
+             in checkToken toks (onionNodeInfo oaddr) tok >>= go
+        `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e)
+ where
+    go withTok = do
+        let naddr = onionNodeInfo oaddr
+        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
+        tm <- getPOSIXTime
+
+        let storing = case oaddr of
+                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
+                        _                  -> Nothing
+        dput XAnnounce   $ unlines [ "announceH: nodeId          = " ++ show (nodeId naddr)
+                                   , "           announceSeeking = " ++ show (announceSeeking req)
+                                   , "           withTok         = " ++ show withTok
+                                   , "           storing         = " ++ maybe "False" (const "True") storing
+                                   ]
+        record <- atomically $ do
+            forM_ storing $ \retpath -> when withTok $ do
+                let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
+                    -- Note: The following distance calculation assumes that
+                    -- our nodeid doesn't change and is the same for both
+                    -- routing4 and routing6.
+                    d = xorNodeId (nodeId (tentativeId routing))
+                                  (announceSeeking req)
+                modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
+            ks <- readTVar keydb
+            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
+        newtok <- maybe (return $ zeros32)
+                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
+                        storing
+        let k = case record of
+                Nothing                    -> NotStored newtok
+                Just _  | isJust storing   -> Acknowledged newtok
+                Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
+        let response = AnnounceResponse k ns
+        dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response]
+        return response
+
+dataToRouteH ::
+          TVar AnnouncedKeys
+          -> Transport err (OnionDestination r) (OnionMessage f)
+          -> addr
+          -> OnionMessage f
+          -> IO ()
+dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do
+    let k = key2id pub
+    dput XOnion $ "dataToRouteH "++ show k
+    mb <- atomically $ do
+        ks <- readTVar keydb
+        forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
+            writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
+            return rpath
+    dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb)
+    forM_ mb $ \rpath -> do
+        -- forward
+        dput XOnion $ "dataToRouteH sendMessage"
+        sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm
+        dput XOnion $ "Forwarding data-to-route -->"++show k
+
+type NodeDistance = NodeId
+
+data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
+
+toOnionDestination :: AnnouncedRoute -> OnionDestination r
+toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
+
+-- |
+-- The type 'NodeId' was originally made for the DHT key, but here
+-- we reuse it for user keys (public key/real key).
+--
+-- To find someone using their user (public) key, you search for it on
+-- kademlia. At each iteration of the search, you get a response with
+-- closest known nodes(DHT keys) to the key you are searching for.
+--
+-- To do an 'Announce' so your friends can find you, you do a search to
+-- find the closest nodes to your own user(public) key. At those nodes,
+-- you store a route back to yourself (using Announce message) so your
+-- friends can contact you. This means each node needs to store the
+-- saved routes, and that is the purpose of the 'AnnouncedKeys' data
+-- structure.
+--
+data AnnouncedKeys = AnnouncedKeys
+    { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-}))
+    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute))
+        -- ^ PSQ using NodeId(user/public key) as Key
+        --   and using 'NodeDistance' as priority.
+        --   (smaller number is higher priority)
+        --
+        --  Keeping in a MinMaxPSQ will help us later when we want to make the structure
+        --  bounded. (We simply throw away the most NodeDistant keys.
+    }
+
+
+insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
+insertKey tm pub toxpath d keydb = AnnouncedKeys
+    { keyByAge = PSQ.insert pub tm (keyByAge keydb)
+    , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
+                    Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
+                    Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
+    }
+
+-- | Forks a thread to garbage-collect old key announcements.  Keys may be
+-- discarded after 5 minutes.
+forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId
+forkAnnouncedKeysGC db = forkIO $ do
+    myThreadId >>= flip labelThread "gc:toxids"
+    fix $ \loop -> do
+    cutoff <- getPOSIXTime
+    threadDelay 300000000 -- 300 seconds
+    join $ atomically $ do
+        fix $ \gc -> do
+        keys <- readTVar db
+        case PSQ.minView (keyByAge keys) of
+            Nothing -> return loop
+            Just (pub :-> tm,kba')
+                | tm > cutoff -> return loop
+                | otherwise   -> do writeTVar db keys
+                                        { keyByAge = kba'
+                                        , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys)
+                                        }
+                                    gc
+
+areq :: Message -> Either String AnnounceRequest
+areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
+areq _                     = Left "Unexpected non-announce OnionMessage"
+
+handlers :: Transport err (OnionDestination r) Message
+            -> Routing
+            -> TVar SessionTokens
+            -> TVar AnnouncedKeys
+            -> PacketKind
+            -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
+handlers net routing toks keydb AnnounceType
+    = Just
+    $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
+    $ announceH routing toks keydb
+handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
+
+
+toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> TransportCrypto
+               -> Client r
+               -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
+toxidSearch getTimeout crypto client = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = Right $ asyncGetRendezvous getTimeout crypto client
+    , searchAlpha = 3
+    , searchK     = 6
+    }
+
+announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+                   -> MethodSerializer
+                        TransactionId
+                        (OnionDestination r)
+                        (OnionMessage Identity)
+                        PacketKind
+                        AnnounceRequest
+                        (Maybe AnnounceResponse)
+announceSerializer getTimeout = MethodSerializer
+    { methodTimeout = getTimeout
+    , method = AnnounceType
+    , wrapQuery = \(TransactionId n8 n24) src dst req ->
+        -- :: tid -> addr -> addr -> a -> OnionMessage Identity
+        OnionAnnounce $ Asymm
+            { -- The public key is our real long term public key if we want to
+              -- announce ourselves, a temporary one if we are searching for
+              -- friends.
+              senderKey = onionKey src
+            , asymmNonce = n24
+            , asymmData = Identity (req, n8)
+            }
+    , unwrapResponse = \case -- :: OnionMessage Identity -> b
+        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
+        _                              -> Nothing
+    }
+
+unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
+unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
+    = case is_stored of
+        NotStored n32    -> ( ns , []                                                        , Just n32)
+        SendBackKey k    -> ( ns , [Rendezvous k ni]                                         , Nothing )
+        Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
+
+-- TODO Announce key to announce peers.
+--
+--   Announce Peers are only put in the 8 closest peers array if they respond
+--   to an announce request. If the peers fail to respond to 3 announce
+--   requests they are deemed timed out and removed.
+--
+--   ...
+--
+--   For this reason, after the peer is announced successfully for 17 seconds,
+--   announce packets are sent aggressively every 3 seconds to each known close
+--   peer (in the list of 8 peers) to search aggressively for peers that know
+--   the peer we are searching for.
+
+-- TODO
+-- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will
+-- aggressively reannounce itself and search for friends as if it was just
+-- started.
+
+
+sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> Client r
+            -> AnnounceRequest
+            -> OnionDestination r
+            -> (NodeInfo -> AnnounceResponse -> t)
+            -> IO (Maybe t)
+sendOnion getTimeout client req oaddr unwrap =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
+    forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
+    maybe (if n>0 then loop $! n - 1 else return Nothing)
+          (return . Just . unwrap (onionNodeInfo oaddr))
+          $ join mb
+
+asyncOnion :: (TransactionId
+                     -> OnionDestination r -> STM (OnionDestination r, Int))
+                    -> QR.Client
+                         err
+                         PacketKind
+                         TransactionId
+                         (OnionDestination r)
+                         (OnionMessage Identity)
+                    -> AnnounceRequest
+                    -> OnionDestination r
+                    -> (NodeInfo -> AnnounceResponse -> a)
+                    -> (Maybe a -> IO ())
+                    -> IO ()
+asyncOnion getTimeout client req oaddr unwrap go =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    QR.asyncQuery client (announceSerializer getTimeout) req oaddr
+        $ \mb -> do
+            forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
+            maybe (if n>0 then loop $! n - 1 else go Nothing)
+                  (go . Just . unwrap (onionNodeInfo oaddr))
+                  $ join mb
+
+
+-- | Lookup the secret counterpart for a given alias key.
+getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> TransportCrypto
+            -> Client r
+            -> NodeId
+            -> NodeInfo
+            -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32))
+getRendezvous getTimeout crypto client nid ni = do
+    asel <- atomically $ selectAlias crypto nid
+    let oaddr = OnionDestination asel ni Nothing
+        rkey  = case asel of
+                    SearchingAlias -> Nothing
+                    _              -> Just $ key2id $ rendezvousPublic crypto
+    sendOnion getTimeout client
+        (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
+        oaddr
+        (unwrapAnnounceResponse rkey)
+
+asyncGetRendezvous
+    :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+       -> TransportCrypto
+       -> Client r
+       -> NodeId
+       -> NodeInfo
+       -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ())
+       -> IO ()
+asyncGetRendezvous getTimeout crypto client nid ni go = do
+    asel <- atomically $ selectAlias crypto nid
+    let oaddr = OnionDestination asel ni Nothing
+        rkey  = case asel of
+                    SearchingAlias -> Nothing
+                    _              -> Just $ key2id $ rendezvousPublic crypto
+    asyncOnion getTimeout client
+        (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
+        oaddr
+        (unwrapAnnounceResponse rkey)
+        go
+
+putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> TransportCrypto
+               -> Client r
+               -> PublicKey
+               -> Nonce32
+               -> NodeInfo
+               -> IO (Maybe (Rendezvous, AnnounceResponse))
+putRendezvous getTimeout crypto client pubkey nonce32 ni = do
+    let longTermKey   = key2id pubkey
+        rkey          = rendezvousPublic crypto
+        rendezvousKey = key2id rkey
+    asel <- atomically $ selectAlias crypto longTermKey
+    let oaddr = OnionDestination asel ni Nothing
+    sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr
+        $ \ni resp -> (Rendezvous rkey ni, resp)
diff --git a/dht/src/Network/Tox/Onion/Transport.hs b/dht/src/Network/Tox/Onion/Transport.hs
new file mode 100644
index 00000000..e746c414
--- /dev/null
+++ b/dht/src/Network/Tox/Onion/Transport.hs
@@ -0,0 +1,119 @@
+module Network.Tox.Onion.Transport
+    ( parseOnionAddr
+    , encodeOnionAddr
+    , parseDataToRoute
+    , encodeDataToRoute
+    , forwardOnions
+    , AliasSelector(..)
+    , OnionDestination(..)
+    , OnionMessage(..)
+    , Rendezvous(..)
+    , DataToRoute(..)
+    , OnionData(..)
+    , AnnouncedRendezvous(..)
+    , AnnounceResponse(..)
+    , AnnounceRequest(..)
+    , Forwarding(..)
+    , ReturnPath(..)
+    , OnionRequest(..)
+    , OnionResponse(..)
+    , Addressed(..)
+    , UDPTransport
+    , KeyRecord(..)
+    , encrypt
+    , decrypt
+    , peelSymmetric
+    , OnionRoute(..)
+    , N0
+    , N1
+    , N2
+    , N3
+    , onionKey
+    , onionAliasSelector
+    , selectAlias
+    , RouteId(..)
+    , routeId
+    , putRequest
+    , wrapForRoute
+    , wrapSymmetric
+    , wrapOnion
+    , wrapOnionPure
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.Serialize
+import Network.Socket
+
+import Crypto.Tox hiding (encrypt,decrypt)
+import qualified Data.Tox.Relay as TCP
+import Data.Tox.Onion
+import Network.Tox.NodeId
+
+{-
+encodeOnionAddr :: TransportCrypto
+                   -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
+                   -> (OnionMessage Encrypted,OnionDestination RouteId)
+                   -> IO (Maybe (ByteString, SockAddr))
+-}
+encodeOnionAddr :: TransportCrypto
+                     -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
+                     -> (OnionMessage Encrypted, OnionDestination RouteId)
+                     -> IO (Maybe
+                             (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr)))
+encodeOnionAddr crypto _ (msg,OnionToOwner ni p) =
+    return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg)
+                          , nodeAddr ni )
+encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do
+    encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) )
+    -- dput XMisc $ "ONION encode missing routeid"
+    -- return Nothing
+encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
+    let go route = do
+            mreq <- wrapForRoute crypto msg ni route
+            case mreq of
+                Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route)
+                Left o | Just port <- routeRelayPort route
+                          -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port)
+    m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid
+    x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m
+    return x
+
+-- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0)
+wrapForRoute :: TransportCrypto
+                      -> OnionMessage Encrypted
+                      -> NodeInfo
+                      -> OnionRoute
+                      -> IO (Either TCP.RelayPacket (OnionRequest N0))
+wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = do
+    -- We needn't use the same nonce value here, but I think it is safe to do so.
+    let nonce = msgNonce msg
+    fwd <-  wrapOnion crypto (routeAliasA r)
+                             nonce
+                             (id2key . nodeId $ routeNodeA r)
+                             (nodeAddr $ routeNodeB r)
+        =<< wrapOnion crypto (routeAliasB r)
+                             nonce
+                             (id2key . nodeId $ routeNodeB r)
+                             (nodeAddr $ routeNodeC r)
+        =<< wrapOnion crypto (routeAliasC r)
+                             nonce
+                             (id2key . nodeId $ routeNodeC r)
+                             (nodeAddr ni)
+                             (NotForwarded msg)
+    return $ Right OnionRequest
+        { onionNonce    = nonce
+        , onionForward  = fwd
+        , pathFromOwner = NoReturnPath
+        }
+wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do
+    let nonce = msgNonce msg
+    fwd <- wrapOnion crypto (routeAliasB r)
+                             nonce
+                             (id2key . nodeId $ routeNodeB r)
+                             (nodeAddr $ routeNodeC r)
+        =<< wrapOnion crypto (routeAliasC r)
+                             nonce
+                             (id2key . nodeId $ routeNodeC r)
+                             (nodeAddr ni)
+                             (NotForwarded msg)
+    return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd
diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs
new file mode 100644
index 00000000..2842fcc2
--- /dev/null
+++ b/dht/src/Network/Tox/Relay.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Network.Tox.Relay (tcpRelay) where
+
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.ByteString as B
+import Data.Function
+import Data.Functor.Identity
+import qualified Data.IntMap     as IntMap
+         ;import Data.IntMap     (IntMap)
+import qualified Data.Map        as Map
+         ;import Data.Map        (Map)
+import Data.Serialize
+import Data.Word
+import Network.Socket (SockAddr)
+import System.IO
+import System.IO.Error
+import System.Timeout
+
+import Crypto.Tox
+import qualified Data.IntervalSet as IntSet
+         ;import Data.IntervalSet (IntSet)
+import Data.Tox.Relay
+import Network.Address (getBindAddress)
+import Network.SocketLike
+import Network.StreamServer
+import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
+
+
+
+hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
+hGetPrefixed h = do
+    mlen <- runGet getWord16be <$> B.hGet h 2
+    -- We treat parse-fail the same as EOF.
+    fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len)
+
+hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x)
+hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF.
+ where
+    ConstSize len = size :: Size x
+
+data RelaySession = RelaySession
+    { indexPool  :: IntSet                                   -- ^ Ints that are either solicited or associated.
+    , solicited  :: Map PublicKey Int                        -- ^ Reserved ids, not yet in associated.
+    , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to.
+    }
+
+freshSession :: RelaySession
+freshSession = RelaySession
+    { indexPool  = IntSet.empty
+    , solicited  = Map.empty
+    , associated = IntMap.empty
+    }
+
+disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
+                -> PublicKey
+                -> IO ()
+disconnect cons who = join $ atomically $ do
+    Map.lookup who <$> readTVar cons
+        >>= \case
+        Nothing -> return $ return ()
+        Just (_,session) -> do
+            modifyTVar' cons $ Map.delete who
+            RelaySession { associated = cs } <- readTVar session
+            return $ let notifyPeer i send = ((send DisconnectNotification) >>)
+                     in IntMap.foldrWithKey notifyPeer (return ()) cs
+
+relaySession :: TransportCrypto
+                -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
+                -> (SockAddr -> OnionRequest N1 -> IO ())
+                -> sock
+                -> Int
+                -> Handle
+                -> IO ()
+relaySession crypto cons sendOnion _ conid h = do
+    -- atomically $ modifyTVar' cons $ IntMap.insert conid h
+
+    -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h
+
+    (hGetSized h >>=) $ mapM_ $ \helloE -> do
+
+    let me = transportSecret crypto
+        them = helloFrom helloE
+
+    noncef <- lookupNonceFunction crypto me them
+    let mhello = decryptPayload (noncef $ helloNonce helloE) helloE
+    forM_ mhello $ \hello -> do
+        let _ = hello :: Hello Identity
+
+        (me',welcome) <- atomically $ do
+            skey <- transportNewKey crypto
+            dta <- HelloData (toPublic skey) <$> transportNewNonce crypto
+            w24 <- transportNewNonce crypto
+            return (skey, Welcome w24 $ pure dta)
+
+        B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
+
+        noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
+                   in lookupNonceFunction crypto me' them'
+
+        let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h
+            base = sessionBaseNonce $ runIdentity $ helloData hello
+
+        -- You get 3 seconds to send a session packet.
+        mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base)
+        forM_ mpkt0 $ \pkt0 -> do
+
+            disconnect cons (helloFrom hello)
+            (sendPacket,session) <- do
+                session <- atomically $ newTVar freshSession
+                sendPacket <- do
+                    v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
+                    return $ \p -> do
+                        case p of
+                            DisconnectNotification con -> atomically $ do
+                                modifyTVar' session $ \s -> s
+                                    { indexPool = maybe id IntSet.delete (c2key con) (indexPool s)
+                                    , associated = maybe id IntMap.delete (c2key con) (associated s)
+                                    }
+                            _ -> return ()
+                        n24 <- takeMVar v
+                        let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket)
+                        do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16)
+                           B.hPut h bs
+                         `catchIOError` \_ -> return ()
+                        putMVar v (incrementNonce24 n24)
+                atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session)
+                return (sendPacket,session)
+
+            handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
+
+            flip fix (incrementNonce24 base)  $ \loop n24 -> do
+                m <- readPacket n24
+                forM_ m $ \p -> do
+                    handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
+                    loop (incrementNonce24 n24)
+         `finally`
+            disconnect cons (helloFrom hello)
+
+handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
+                      -> Int
+                      -> PublicKey
+                      -> TransportCrypto
+                      -> (SockAddr -> OnionRequest N1 -> IO ())
+                      -> (RelayPacket -> IO ())
+                      -> TVar RelaySession
+                      -> RelayPacket
+                      -> IO ()
+handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
+    RoutingRequest them -> join $ atomically $ do
+        mySession <- readTVar session
+        mi <- case Map.lookup them (solicited mySession) of
+            Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do
+                if -120 <= i && i <= 119
+                    then do
+                        writeTVar session mySession
+                            { indexPool = IntSet.insert i (indexPool mySession)
+                            , solicited = Map.insert them i (solicited mySession)
+                            }
+                        return $ Just i
+                    else return Nothing -- No more slots available.
+            Just i  -> return $ Just i
+        notifyConnect <- fmap (join . join) $ forM mi $ \i -> do
+            mp <- Map.lookup them <$> readTVar cons
+            forM mp $ \(sendToThem,peer) -> do
+                theirSession <- readTVar peer
+                forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do
+                    let sendToThem' f = sendToThem $ f $ key2c reserved_id
+                        sendToMe'   f = sendToMe   $ f $ key2c i
+                    writeTVar peer theirSession
+                        { solicited  = Map.delete me (solicited theirSession)
+                        , associated = IntMap.insert reserved_id sendToMe' (associated theirSession)
+                        }
+                    writeTVar session mySession
+                        { solicited  = Map.delete them (solicited mySession)
+                        , associated = IntMap.insert i sendToThem' (associated mySession)
+                        }
+                    return $ do sendToThem' ConnectNotification
+                                sendToMe'   ConnectNotification
+        return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them
+                    sequence_ notifyConnect
+
+    RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid.  Do we care?
+
+    OOBSend them bs -> do
+        m <- atomically $ Map.lookup them <$> readTVar cons
+        forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs
+
+    RelayData bs con -> join $ atomically $ do
+        -- Data: Data packets can only be sent and received if the
+        -- corresponding connection_id is connection (a Connect notification
+        -- has been received from it) if the server receives a Data packet for
+        -- a non connected or existent connection it will discard it.
+        mySession <- readTVar session
+        return $ sequence_ $ do
+            i <- c2key con
+            sendToThem' <- IntMap.lookup i $ associated mySession
+            return $ sendToThem' $ RelayData bs
+
+    OnionPacket n24 (Addressed addr req) -> do
+        rpath <- atomically $ do
+                    sym <- transportSymmetric crypto
+                    n <- transportNewNonce crypto
+                    return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath
+        sendOnion addr $ OnionRequest n24 req rpath
+
+    _ -> return ()
+
+
+sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO ()
+sendTCP_ st addr x = join $ atomically
+    $ IntMap.lookup addr <$> readTVar st >>= \case
+        Nothing   -> return $ return ()
+        Just send -> return $ send $ OnionPacketResponse x
+
+tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ())
+tcpRelay udp_addr sendOnion = do
+    crypto <- newCrypto
+    cons <- newTVarIO Map.empty
+    clients <- newTVarIO IntMap.empty
+    b443   <- getBindAddress "443"   True
+    b80    <- getBindAddress "80"    True
+    b33445 <- getBindAddress "33445" True
+    bany   <- getBindAddress ""      True
+    h <- streamServer ServerConfig
+                        { serverWarn    = hPutStrLn stderr
+                        , serverSession = relaySession crypto cons sendOnion
+                        }
+                      [b443,b80,udp_addr,b33445,bany]
+    return (h,sendTCP_ clients)
+
diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs
new file mode 100644
index 00000000..189967fa
--- /dev/null
+++ b/dht/src/Network/Tox/Session.hs
@@ -0,0 +1,243 @@
+-- | This module implements the lossless Tox session protocol.
+{-# LANGUAGE TupleSections #-}
+module Network.Tox.Session
+    ( SessionParams(..)
+    , SessionKey
+    , Session(..)
+    , sTheirUserKey
+    , sClose
+    , handshakeH
+    ) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Exception
+import Data.Dependent.Sum
+import Data.Functor.Identity
+import Data.Word
+import Network.Socket         (SockAddr)
+
+import Crypto.Tox
+import Data.PacketBuffer            (PacketInboundEvent (..))
+import Data.Tox.Msg
+import DPut
+import DebugTag
+import Network.Lossless
+import Network.QueryResponse
+import Network.SessionTransports
+import Network.Tox.Crypto.Transport
+import Network.Tox.DHT.Transport    (Cookie (..), key2id, longTermKey)
+import Network.Tox.Handshake
+
+-- | Alias for 'SecretKey' to document that it is used as the temporary Tox
+-- session key corresponding to the 'PublicKey' we sent in the handshake.
+type SessionKey = SecretKey
+
+-- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to
+-- assign packets to sessions, and what to do with established sessions after
+-- they are made lossless by queuing packets and appending sequence numbers.
+data SessionParams = SessionParams
+    { -- | The database of secret keys necessary to encrypt handshake packets.
+      spCrypto           :: TransportCrypto
+      -- | This is used to create sessions and dispatch packets to them.
+    , spSessions         :: Sessions (CryptoPacket Encrypted)
+      -- | This method returns the session information corresponding to the
+      -- cookie pair for the remote address.  If no handshake was sent, this
+      -- should send one immediately.  It should return 'Nothing' if anything
+      -- goes wrong.
+    , spGetSentHandshake :: SecretKey -> SockAddr
+                                      -> Cookie Identity
+                                      -> Cookie Encrypted
+                                      -> IO (Maybe (SessionKey, HandshakeData))
+      -- | This method is invoked on each new session and is responsible for
+      -- launching any threads necessary to keep the session alive.
+    , spOnNewSession     :: Session -> IO ()
+    }
+
+-- | After a session is established, this information is given to the
+-- 'spOnNewSession' callback.
+data Session = Session
+    { -- | This is the secret user (toxid) key that corresponds to the
+      -- local-end of this session.
+      sOurKey            :: SecretKey
+      -- | The remote address for this session. (Not unique, see 'sSessionID').
+    , sTheirAddr         :: SockAddr
+      -- | The information we sent in the handshake for this session.
+    , sSentHandshake     :: HandshakeData
+      -- | The information we received in a handshake for this session.
+    , sReceivedHandshake :: Handshake Identity
+      -- | This method can be used to trigger packets to be re-sent given a
+      -- list of their sequence numbers.  It should be used when the remote end
+      -- indicates they lost packets.
+    , sResendPackets     :: [Word32] -> IO ()
+      -- | This list of sequence numbers should be periodically polled and if
+      -- it is not empty, we should request they re-send these packets.  For
+      -- convenience, a lower bound for the numbers in the list is also
+      -- returned.  Suggested polling interval: a few seconds.
+    , sMissingInbound    :: IO ([Word32],Word32)
+      -- | A lossless transport for sending and receiving packets in this
+      -- session.  It is up to the caller to spawn the await-loop to handle
+      -- inbound packets.
+    , sTransport         :: Transport String () CryptoMessage
+      -- | A unique small integer that identifies this session for as long as
+      -- it is established.
+    , sSessionID         :: Int
+    }
+
+-- | Helper to obtain the remote ToxID key from the locally-issued cookie
+-- associated with the session.
+sTheirUserKey :: Session -> PublicKey
+sTheirUserKey s = longTermKey $ runIdentity cookie
+ where
+    Cookie _ cookie = handshakeCookie (sReceivedHandshake s)
+
+-- | Helper to close the 'Transport' associated with a session.
+sClose :: Session -> IO ()
+sClose s = closeTransport (sTransport s)
+
+
+-- | Call this whenever a new handshake arrives so that a session is
+-- negotiated.  It always returns Nothing which makes it convenient to use with
+-- 'Network.QueryResponse.addHandler'.
+handshakeH :: SessionParams
+              -> SockAddr
+              -> Handshake Encrypted
+              -> IO (Maybe a)
+handshakeH sp saddr handshake = do
+    decryptHandshake (spCrypto sp) handshake
+        >>= either (\err -> return ())
+                   (uncurry $ plainHandshakeH sp saddr)
+    return Nothing
+
+
+plainHandshakeH :: SessionParams
+                   -> SockAddr
+                   -> SecretKey
+                   -> Handshake Identity
+                   -> IO ()
+plainHandshakeH sp saddr skey handshake = do
+    let hd = runIdentity $ handshakeData handshake
+        prelude = show saddr ++ " --> "
+    dput XNetCrypto $ unlines $ map (prelude ++)
+        [ "handshake: auth=" ++ show (handshakeCookie handshake)
+        , "         : issuing=" ++ show (otherCookie hd)
+        , "         : baseNonce=" ++ show (baseNonce hd)
+        ]
+    sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd)
+    -- TODO: this is always returning sent = Nothing
+    dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent)
+    forM_ sent $ \(hd_skey,hd_sent) -> do
+    sk <- SessionKeys (spCrypto sp)
+                      hd_skey
+                      (sessionKey hd)
+                      <$> atomically (newTVar $ baseNonce hd)
+                      <*> atomically (newTVar $ baseNonce hd_sent)
+    m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr
+    dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m
+    forM_ m $ \(sid, t) -> do
+        (t2,resend,getMissing)
+            <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp)
+                        (\seqno p@(Pkt m :=> _) _ -> do
+                            y <- encryptPacket sk $ bookKeeping seqno p
+                            return OutgoingInfo
+                                { oIsLossy         = lossyness m == Lossy
+                                , oEncoded         = y
+                                , oHandleException = Just $ \e -> do
+                                        dput XUnexpected $ unlines
+                                            [ "<-- " ++ show e
+                                            , "<--   while sending " ++ show (seqno,p) ]
+                                        throwIO e
+                                })
+                        ()
+                        t
+        let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted)
+            _ = t2 :: Transport String () CryptoMessage
+        sendMessage t2 () $ (Pkt ONLINE ==> ())
+        spOnNewSession sp Session
+            { sOurKey            = skey
+            , sTheirAddr         = saddr
+            , sSentHandshake     = hd_sent
+            , sReceivedHandshake = handshake
+            , sResendPackets     = resend
+            , sMissingInbound    = getMissing
+            , sTransport         = t2
+            , sSessionID         = sid
+            }
+    return ()
+
+
+-- | The per-session nonce and key state maintained by 'decryptPacket' and
+-- 'encryptPacket'.
+data SessionKeys = SessionKeys
+    { skCrypto        :: TransportCrypto -- ^ Cache of shared-secrets.
+    , skMe            :: SessionKey      -- ^ My session key
+    , skThem          :: PublicKey       -- ^ Their session key
+    , skNonceIncoming :: TVar Nonce24    -- ^ +21845 when a threshold is reached.
+    , skNonceOutgoing :: TVar Nonce24    -- ^ +1 on every packet
+    }
+
+-- | Decrypt an inbound session packet and update the nonce for the next one.
+decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ()))
+decryptPacket sk saddr (CryptoPacket n16 ciphered) = do
+    (n24,δ) <- atomically $ do
+        n <- readTVar (skNonceIncoming sk)
+        let δ = n16 - nonce24ToWord16 n
+        return ( n `addtoNonce24` fromIntegral δ, δ )
+    secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
+    case decodePlain =<< decrypt secret ciphered of
+        Left e  -> return Nothing
+        Right x -> do
+            when ( δ  > 43690 )
+                $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845)
+
+            do let them = key2id $ skThem sk
+                   CryptoData ack seqno _ = x
+                   cm = decodeRawCryptoMsg x
+               dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)]
+
+            return $ Just ( CryptoPacket n16 (pure x), () )
+
+-- | Encrypt an outbound session packet and update the nonce for the next one.
+encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted)
+encryptPacket sk plain = do
+    n24 <- atomically $ do
+        n24 <- readTVar (skNonceOutgoing sk)
+        modifyTVar' (skNonceOutgoing sk) incrementNonce24
+        return n24
+    secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
+    let ciphered = encrypt secret $ encodePlain $ plain
+
+    do let them = key2id $ skThem sk
+           CryptoData ack seqno cm = plain
+       dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)]
+
+    return $ CryptoPacket (nonce24ToWord16 n24) ciphered
+
+
+-- | Add sequence information to an outbound packet.
+--
+-- From spec.md:
+--
+--   Data in the encrypted packets:
+--
+--    [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
+--    [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)]
+--    [data]
+bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData
+bookKeeping (SequenceInfo seqno ack) m = CryptoData
+    { bufferStart = ack   :: Word32
+    , bufferEnd   = seqno :: Word32
+    , bufferData  = m
+    }
+
+-- | Classify an inbound packet as lossy or lossless based on its id byte.
+checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage
+checkLossless cd@CryptoData{ bufferStart = ack
+                           , bufferEnd   = no
+                           , bufferData  = x   } = tag no x' ack
+ where
+    x' = decodeRawCryptoMsg cd
+    tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy
+                                           _     -> PacketReceived
+
+
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
new file mode 100644
index 00000000..13da804f
--- /dev/null
+++ b/dht/src/Network/Tox/TCP.hs
@@ -0,0 +1,313 @@
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Network.Tox.TCP
+    ( module Network.Tox.TCP
+    , NodeInfo(..)
+    ) where
+
+import Debug.Trace
+import Control.Arrow
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import Crypto.Random
+import Data.Aeson (ToJSON(..),FromJSON(..))
+import qualified Data.Aeson as JSON
+import Data.Functor.Contravariant
+import Data.Functor.Identity
+import Data.Hashable
+import qualified Data.HashMap.Strict as HashMap
+import Data.IP
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize
+import Data.Word
+import qualified Data.Vector as Vector
+import Network.Socket (SockAddr(..))
+import qualified Text.ParserCombinators.ReadP as RP
+import System.IO.Error
+import System.Timeout
+
+import ControlMaybe
+import Crypto.Tox
+import Data.ByteString (hPut,hGet,ByteString,length)
+import Data.TableMethods
+import Data.Tox.Relay
+import qualified Data.Word64Map
+import DebugTag
+import DPut
+import Network.Address (setPort,PortNumber,localhost4,fromSockAddr)
+import Network.Kademlia.Routing
+import Network.Kademlia.Search hiding (sendQuery)
+import Network.QueryResponse
+import Network.QueryResponse.TCP
+import Network.Tox.DHT.Handlers (toxSpace)
+import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
+import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
+import qualified Network.Tox.NodeId as UDP
+
+
+withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
+withSize f = case size of len -> f len
+
+
+type NodeId = UDP.NodeId
+
+-- example:
+-- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443}
+instance Show NodeInfo where
+    show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}"
+
+nodeId :: NodeInfo -> NodeId
+nodeId ni = UDP.nodeId $ udpNodeInfo ni
+
+nodeAddr :: NodeInfo -> SockAddr
+nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni
+
+nodeIP :: NodeInfo -> IP
+nodeIP ni = UDP.nodeIP $ udpNodeInfo ni
+
+tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) =>
+                   TransportCrypto -> StreamHandshake NodeInfo x y
+tcpStream crypto = StreamHandshake
+    { streamHello = \addr h -> do
+        (skey, hello) <- atomically $ do
+            n24 <- transportNewNonce crypto
+            skey <- transportNewKey crypto
+            base24 <- transportNewNonce crypto
+            return $ (,) skey $ Hello $ Asymm
+                { senderKey  = transportPublic crypto
+                , asymmNonce = n24
+                , asymmData  = pure HelloData
+                                { sessionPublicKey = toPublic $ skey
+                                , sessionBaseNonce = base24
+                                }
+                }
+        noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
+        dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
+        hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
+        welcomeE <- withSize $ fmap decode . hGet h . constSize
+        let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
+            nil = SessionProtocol
+                { streamGoodbye = return ()
+                , streamDecode = return Nothing
+                , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y
+                }
+        either (\_ -> return nil) id $ mwelcome <&> \welcome -> do
+        dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
+        noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
+        nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
+        nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
+        let them = sessionPublicKey $ runIdentity $ welcomeData welcome
+        hvar <- newMVar h
+        return SessionProtocol
+            { streamGoodbye = do
+                dput XTCP $ "Closing " ++ show addr
+                return () -- No goodbye packet?  Seems rude.
+            , streamDecode =
+                let go h = decode <$> hGet h 2 >>= \case
+                        Left e    -> do
+                            dput XTCP $ "TCP: (" ++ show addr ++ ") Failed to get length: " ++ e
+                            return Nothing
+                        Right len -> do
+                            decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case
+                                Left e  -> do
+                                    dput XTCP $ "TCP: Failed to decode packet."
+                                    return Nothing
+                                Right x -> do
+                                    m24 <- timeout 1000000 (takeMVar nread)
+                                    fmap join $ forM m24 $ \n24 -> do
+                                        let r = decrypt (noncef' n24) x >>= decodePlain
+                                        putMVar nread (incrementNonce24 n24)
+                                        either (dput XTCP . ("TCP decryption: " ++))
+                                               (\x' -> do
+                                                    dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
+                                                    return ())
+                                               r
+                                        return $ either (const Nothing) Just r
+                 in bracket (takeMVar hvar) (putMVar hvar)
+                     $ \h -> go h `catchIOError` \e -> do
+                                        dput XTCP $ "TCP exception: " ++ show e
+                                        return Nothing
+            , streamEncode = \y -> do
+                dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
+                n24 <- takeMVar nsend
+                dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
+                let bs = encode $ encrypt (noncef' n24) $ encodePlain y
+                ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
+                    $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
+                                `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
+                dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
+                putMVar nsend (incrementNonce24 n24)
+                dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y
+            }
+    , streamAddr = nodeAddr
+    }
+
+toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket)
+                                , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) )
+toxTCP crypto = tcpTransport 30 (tcpStream crypto)
+
+tcpSpace :: KademliaSpace NodeId NodeInfo
+tcpSpace = contramap udpNodeInfo toxSpace
+
+{-
+nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
+nodeSearch tcp = Search
+    { searchSpace       = tcpSpace
+    , searchNodeAddress = nodeIP &&& tcpPort
+    , searchQuery       = getNodes tcp
+    }
+-}
+
+data TCPClient err tid = TCPClient
+    { tcpCrypto     :: TransportCrypto
+    , tcpClient     :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket)
+    , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo)
+    }
+
+{-
+getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getTCPNodes tcp seeking dst = do
+    r <- getUDPNodes' tcp seeking (udpNodeInfo dst)
+    let tcps (ns,_,mb) = (ns',ns',mb)
+         where ns' = do
+                    n <- ns
+                    [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ]
+    fmap join $ forM r $ \(ns,gw) -> do
+        let ts = tcps ns
+        {-
+        if nodeId gw == nodeId dst
+            then return $ Just ts
+            else do
+                forkIO $ void $ tcpPing (tcpClient tcp) dst
+                return $ Just ts
+        -}
+        forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp))
+        return $ Just ts
+-}
+
+getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
+getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst
+
+getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
+getUDPNodes' tcp seeking dst0 = do
+    mgateway <- atomically $ tcpGetGateway tcp dst0
+    fmap join $ forM mgateway $ \gateway -> do
+        (b,c,n24) <- atomically $ do
+            b <- transportNewKey (tcpCrypto tcp)
+            c <- transportNewKey (tcpCrypto tcp)
+            n24 <- transportNewNonce (tcpCrypto tcp)
+            return (b,c,n24)
+        let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway
+                                then ( dst0 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }
+                                     , gateway { udpNodeInfo = (udpNodeInfo gateway)
+                                                    { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }})
+                                else (dst0,gateway)
+        wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst)
+        wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway)
+        wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst)
+        let meth :: MethodSerializer
+                        Nonce8
+                        a -- NodeInfo
+                        (Bool, RelayPacket)
+                        PacketNumber
+                        AnnounceRequest
+                        (Either String AnnounceResponse)
+            meth = MethodSerializer
+                    { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout
+                    , method = OnionPacketID -- meth
+                    , wrapQuery = \n8 src gateway x -> (,) True $
+                        OnionPacket n24 $ Addressed (UDP.nodeAddr dst)
+                            $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway')
+                                $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst)
+                                    $ NotForwarded $ encryptPayload (wrap0 n24)
+                                       $ OnionAnnounce Asymm
+                                            { senderKey  = transportPublic (tcpCrypto tcp)
+                                            , asymmNonce = n24
+                                            , asymmData  = pure (x,n8)
+                                            }
+                    , unwrapResponse = \case
+                        (_,OnionPacketResponse (OnionAnnounceResponse _ n24' r))
+                            -> decrypt (wrap0 n24') r >>= decodePlain
+                        x   -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x
+                    }
+        r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway
+        forM r $ \response -> do
+            let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response
+            return ( (ns,ns, const () <$> mb), gateway )
+
+
+handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
+handleOOB k bs src dst = do
+    dput XMisc $ "TODO: handleOOB " ++ show src
+    return Nothing
+
+handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
+handle2route o src dst = do
+    dput XMisc $ "TODO: handle2route " ++ show src
+    return Nothing
+
+tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ())
+tcpPing client dst = do
+    dput XTCP $ "tcpPing " ++ show dst
+    sendQuery client meth () dst
+ where meth = MethodSerializer
+                { wrapQuery      = \n8 src dst () -> (True,RelayPing n8)
+                , unwrapResponse = \_ -> ()
+                , methodTimeout  = \n8 dst -> return (dst,5000000)
+                , method         = PingPacket
+                }
+
+type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
+
+-- | Create a new TCP relay client.  Because polymorphic existential record
+-- updates are currently hard with GHC, this function accepts parameters for
+-- generalizing the table-entry type for pending transactions.  Safe trivial
+-- defaults are 'id' and 'tryPutMVar'.  The resulting customized table state
+-- will be returned to the caller along with the new client.
+newClient :: TransportCrypto
+               -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query
+               -> (a -> RelayPacket -> IO void)  -- ^ load mvar for query
+               -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
+                       , TCPCache (SessionProtocol RelayPacket RelayPacket) )
+                     , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket))
+newClient crypto store load = do
+    (tcpcache,net) <- toxTCP crypto
+    drg <- drgNew
+    map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
+    return $ (,) (map_var,tcpcache) Client
+        { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
+        , clientDispatcher = DispatchMethods
+            { classifyInbound = (. snd) $ \case
+                RelayPing n           -> IsQuery PingPacket n
+                RelayPong n           -> IsResponse n
+                OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
+                OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
+                OOBRecv k bs          -> IsUnsolicited $ handleOOB k bs
+                wut                   -> IsUnknown (show wut)
+            , lookupHandler   = \case
+                PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler
+                    { methodParse     = \case (_,RelayPing n8) -> Right ()
+                                              _                -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?"
+                    , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8)
+                    , methodAction    = \src () -> dput XTCP $ "TCP pinged by "++show src
+                    }
+                w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply
+                            { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a
+                            , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w
+                            }
+            , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
+                                $ first (either error Nonce8 . decode) . randomBytesGenerate 8
+            }
+        , clientErrorReporter = logErrors
+        , clientPending = map_var
+        , clientAddress = \_ -> return $ NodeInfo
+            { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0)
+            , tcpPort = 0
+            }
+        , clientResponseId = return
+        }
diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs
new file mode 100644
index 00000000..217d5b1d
--- /dev/null
+++ b/dht/src/Network/Tox/Transport.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeOperators              #-}
+module Network.Tox.Transport (toxTransport, RouteId) where
+
+import Network.QueryResponse
+import Crypto.Tox
+import Data.Tox.Relay as TCP
+import Network.Tox.DHT.Transport as UDP
+import Network.Tox.Onion.Transport
+import Network.Tox.Crypto.Transport
+import OnionRouter
+
+import Network.Socket
+
+toxTransport ::
+      TransportCrypto
+          -> OnionRouter
+          -> (PublicKey -> IO (Maybe UDP.NodeInfo))
+          -> UDPTransport
+          -> (TCP.NodeInfo -> RelayPacket -> IO ())   -- ^ TCP server-bound callback.
+          -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback.
+          -> IO ( Transport String SockAddr (CryptoPacket Encrypted)
+                , Transport String UDP.NodeInfo (DHTMessage Encrypted8)
+                , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
+                , Transport String AnnouncedRendezvous (PublicKey,OnionData)
+                , Transport String SockAddr (Handshake Encrypted))
+toxTransport crypto orouter closeLookup udp tcp2server tcp2client = do
+    (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
+    (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr)
+                                    $ forwardOnions crypto udp0 tcp2client
+    (onion1,udp2) <- partitionAndForkTransport tcp2server
+                             (parseOnionAddr $ lookupSender orouter)
+                             (encodeOnionAddr crypto $ lookupRoute orouter)
+                             udp1
+    (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
+    let handshakes = layerTransport parseHandshakes encodeHandshakes udp2
+    return ( netcrypto
+           , forwardDHTRequests crypto closeLookup dht
+           , onion
+           , dta
+           , handshakes
+           )
+
+
+-- instance (Sized a, Sized b) => Sized (a,b) where size = _todo
+
+
+--   Byte value   Packet Kind           Return address
+-- :----------- :--------------------
+--   `0x00`       Ping Request          DHTNode
+--   `0x01`       Ping Response         -
+--   `0x02`       Nodes Request         DHTNode
+--   `0x04`       Nodes Response        -
+--   `0x18`       Cookie Request        DHTNode, but without sending pubkey in response
+--   `0x19`       Cookie Response       - (no pubkey)
+--
+--   `0x21`       LAN Discovery         DHTNode (No reply, port 33445, trigger Nodes Request/Response)
+--
+--   `0x20`       DHT Request           DHTNode/-forward
+--
+--   `0x1a`       Crypto Handshake      CookieAddress
+--
+--   `0x1b`       Crypto Data           SessionAddress
+--
+--   `0x83`       Announce Request      OnionToOwner
+--   `0x84`       Announce Response     -
+--   `0x85`       Onion Data Request    OnionToOwner
+--   `0x86`       Onion Data Response   -
+--
+--   `0xf0`       Bootstrap Info        SockAddr?
+--
+--   `0x80`       Onion Request 0       -forward
+--   `0x81`       Onion Request 1       -forward
+--   `0x82`       Onion Request 2       -forward
+--   `0x8c`       Onion Response 3      -return
+--   `0x8d`       Onion Response 2      -return
+--   `0x8e`       Onion Response 1      -return
+
+
+