6 files changed, 144 insertions, 66 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 5279ea54..7562f2ad 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1303,6 +1303,7 @@ initTox opts ssvar keysdb mbxmpp = case porttox opts of
                                 Nothing   -> \_ _ _ -> return ()
                                 Just xmpp -> onNewToxSession xmpp ssvar)
                               (dhtkey opts)
+                              (\_ _ -> return ()) -- TODO: TCP relay send
             (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True
 
             toxSearches <- atomically $ newTVar Map.empty
diff --git a/examples/toxrelay.hs b/examples/toxrelay.hs
index f03605f9..953b230b 100644
--- a/examples/toxrelay.hs
+++ b/examples/toxrelay.hs
@@ -15,6 +15,7 @@ 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
@@ -26,6 +27,7 @@ import Data.Tox.Relay
 import Network.Address (getBindAddress)
 import Network.StreamServer
 import Network.Tox (newCrypto)
+import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
 
 
 
@@ -41,9 +43,9 @@ hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF
     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 (RelayPacket -> IO ()) -- ^ Peers this session is connected to.
+    { 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
@@ -63,16 +65,17 @@ disconnect cons who = join $ atomically $ do
         Just (_,session) -> do
             modifyTVar' cons $ Map.delete who
             RelaySession { associated = cs } <- readTVar session
-            return $ let notifyPeer i send = (send (DisconnectNotification $ key2c i) >>)
+            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 _ conid h = do
+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
@@ -98,16 +101,6 @@ relaySession crypto cons _ conid h = do
         noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
                    in lookupNonceFunction crypto me' them'
 
-        sendPacket <- do
-            v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
-            return $ \p -> do
-                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)
-
         let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h
             base = sessionBaseNonce $ runIdentity $ helloData hello
 
@@ -116,33 +109,47 @@ relaySession crypto cons _ conid h = do
         forM_ mpkt0 $ \pkt0 -> do
 
             disconnect cons (helloFrom hello)
-            session <- atomically $ do
-                session <- newTVar freshSession
-                modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session)
-                return session
-
-            handlePacket cons (helloFrom hello) sendPacket session pkt0
+            (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 (helloFrom hello) sendPacket session p
+                    handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
                     loop (incrementNonce24 n24)
          `finally`
             disconnect cons (helloFrom hello)
 
-data R = R { routingRequest :: PublicKey -> IO ConId
-           , reply :: RelayPacket -> IO ()
-           , routeOOB :: PublicKey -> IO (Maybe (RelayPacket -> IO ()))
-           }
-
 handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
+                      -> Int
                       -> PublicKey
+                      -> TransportCrypto
+                      -> (SockAddr -> OnionRequest N1 -> IO ())
                       -> (RelayPacket -> IO ())
                       -> TVar RelaySession
                       -> RelayPacket
                       -> IO ()
-handlePacket cons me sendToMe session = \case
+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
@@ -161,16 +168,18 @@ handlePacket cons me sendToMe session = \case
             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)
+                        , associated = IntMap.insert reserved_id sendToMe' (associated theirSession)
                         }
                     writeTVar session mySession
                         { solicited  = Map.delete them (solicited mySession)
-                        , associated = IntMap.insert i sendToThem (associated mySession)
+                        , associated = IntMap.insert i sendToThem' (associated mySession)
                         }
-                    return $ do sendToThem $ ConnectNotification (key2c reserved_id)
-                                sendToMe   $ ConnectNotification (key2c i)
+                    return $ do sendToThem' ConnectNotification
+                                sendToMe'   ConnectNotification
         return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them
                     sequence_ notifyConnect
 
@@ -180,7 +189,7 @@ handlePacket cons me sendToMe session = \case
         m <- atomically $ Map.lookup them <$> readTVar cons
         forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs
 
-    RelayData con bs -> join $ atomically $ do
+    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
@@ -188,8 +197,14 @@ handlePacket cons me sendToMe session = \case
         mySession <- readTVar session
         return $ sequence_ $ do
             i <- c2key con
-            sendToThem <- IntMap.lookup i $ associated mySession
-            return $ sendToThem $ RelayData _todo bs
+            sendToThem' <- IntMap.lookup i $ associated mySession
+            return $ sendToThem' $ RelayData bs
+
+    OnionPacket p -> do
+        mp <- rewrap crypto (TCPIndex thistcp) p
+        case mp of
+            Right (p',addr) -> sendOnion addr p'
+            _               -> return ()
 
     _ -> return ()
 
@@ -199,9 +214,11 @@ main = do
     crypto <- newCrypto
     cons <- newTVarIO Map.empty
     a <- getBindAddress "33445" True
+    let sendOnion :: SockAddr -> OnionRequest N1 -> IO ()
+        sendOnion _ _ = return ()
     h <- streamServer ServerConfig
-                        { serverWarn = hPutStrLn stderr
-                        , serverSession = relaySession crypto cons
+                        { serverWarn    = hPutStrLn stderr
+                        , serverSession = relaySession crypto cons sendOnion
                         }
                       a
 
diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
index f801d1cd..82fef126 100644
--- a/src/Data/Tox/Relay.hs
+++ b/src/Data/Tox/Relay.hs
@@ -48,11 +48,11 @@ data RelayPacket
     | OnionPacket (OnionRequest N0)
     | OnionPacketResponse (OnionResponse N1)
     -- 0x0A through 0x0F reserved for future use.
-    | RelayData ConId ByteString -- Word8 is a connection id.  Encoded as number 16 to 255.
+    | RelayData ByteString ConId -- Word8 is a connection id.  Encoded as number 16 to 255.
  deriving (Eq,Ord,Show,Data)
 
 packetNumber :: RelayPacket -> Word8
-packetNumber (RelayData (ConId conid) _) = conid -- 0 to 15 not allowed.
+packetNumber (RelayData _ (ConId conid)) = conid -- 0 to 15 not allowed.
 packetNumber rp                          = fromIntegral $ pred $ constrIndex $ toConstr rp
 
 instance Sized RelayPacket where
@@ -71,7 +71,7 @@ instance Sized RelayPacket where
         OnionPacketResponse answer   -> case contramap (`asTypeOf` answer) size of
                                             ConstSize n -> n
                                             VarSize f   -> f answer
-        RelayData _ bs               -> B.length bs
+        RelayData bs _               -> B.length bs
 
 instance Serialize RelayPacket where
 
@@ -88,7 +88,7 @@ instance Serialize RelayPacket where
             7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes)
             8 -> OnionPacket <$> get
             9 -> OnionPacketResponse <$> get
-            conid -> RelayData (ConId conid) <$> (remaining >>= getBytes)
+            conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes)
 
     put rp = do
         putWord8 $ packetNumber rp
@@ -103,7 +103,7 @@ instance Serialize RelayPacket where
             OOBRecv k bs                 -> putPublicKey k >> putByteString bs
             OnionPacket query            -> put query
             OnionPacketResponse answer   -> put answer
-            RelayData _ bs               -> putByteString bs
+            RelayData bs _               -> putByteString bs
 
 -- | Initial client-to-server handshake message.
 newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData))
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index ddb22d50..b22cfdf3 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -271,10 +271,11 @@ newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rende
        -> SockAddr                   -- ^ Bind-address to listen on.
        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
        -> Maybe SecretKey            -- ^ Optional DHT secret key to use.
+        -> ( Int -> Onion.OnionResponse Onion.N1 -> IO () ) -- ^ TCP-bound onion responses.
        -> IO (Tox extra)
-newTox keydb addr onsess suppliedDHTKey = do
+newTox keydb addr onsess suppliedDHTKey tcp = do
     (udp,sock) <- {- addVerbosity <$> -} udpTransport' addr
-    tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp
+    tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp tcp
     return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) }
 
 -- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
@@ -283,8 +284,9 @@ newToxOverTransport :: TVar Onion.AnnouncedKeys
         -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
         -> Maybe SecretKey
         -> Onion.UDPTransport
+        -> ( Int -> Onion.OnionResponse Onion.N1 -> IO () ) -- ^ TCP-bound onion responses.
         -> IO (Tox extra)
-newToxOverTransport keydb addr onNewSession suppliedDHTKey udp = do
+newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
     roster <- newContactInfo
     crypto0 <- newCrypto
     let -- patch in supplied DHT key
@@ -306,7 +308,7 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp = do
 
     mkrouting <- DHT.newRouting addr crypto updateIP updateIP
     orouter <- newOnionRouter $ dput XRoutes
-    (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp
+    (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp tcp
     sessions <- initSessions (sendMessage cryptonet)
 
     let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 160b99f7..f6d9ca31 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -50,6 +50,7 @@ module Network.Tox.Onion.Transport
     , selectAlias
     , RouteId(..)
     , routeId
+    , rewrap
     ) where
 
 import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
@@ -87,6 +88,8 @@ import qualified Text.ParserCombinators.ReadP as RP
 import Data.Hashable
 import DPut
 import DebugTag
+import Data.Word64Map (fitsInInt)
+import Data.Bits (shiftR,shiftL)
 
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
@@ -270,20 +273,20 @@ encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
     return x
 
 
-forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport
-forwardOnions crypto udp = udp { awaitMessage = forwardAwait crypto udp }
+forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionResponse N1 -> IO ()) {- ^ TCP relay send -} -> UDPTransport
+forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP }
 
-forwardAwait :: TransportCrypto -> UDPTransport -> HandleLo a -> IO a
-forwardAwait crypto udp kont = do
+forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionResponse N1 -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a
+forwardAwait crypto udp sendTCP kont = do
     fix $ \another -> do
       awaitMessage udp $ \case
         m@(Just (Right (bs,saddr))) -> case B.head bs of
-            0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N0) crypto saddr udp another
-            0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N1) crypto saddr udp another
-            0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N2) crypto saddr udp another
-            0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp another
-            0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp another
-            0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp another
+            0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N0) crypto (Addressed saddr) udp another
+            0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N1) crypto (Addressed saddr) udp another
+            0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N2) crypto (Addressed saddr) udp another
+            0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another
+            0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another
+            0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another
             _    -> kont m
         m -> kont m
 
@@ -392,6 +395,7 @@ instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where
     size = contramap pathToOwner size <> contramap msgToOwner size
 
 data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
+                 | TCPIndex { tcpIndex :: Int, unaddressed :: a }
  deriving (Eq,Show)
 
 instance Sized a => Sized (Addressed a) where
@@ -419,9 +423,24 @@ putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family")
             IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
         S.put port
 
+addrToIndex :: SockAddr -> Int
+addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) =
+    if fitsInInt (Proxy :: Proxy Word64)
+        then fromIntegral lo + (fromIntegral hi `shiftL` 32)
+        else fromIntegral lo
+addrToIndex _ = 0
+
+indexToAddr :: Int -> SockAddr
+indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0
+
 instance Serialize a => Serialize (Addressed a) where
-    get = Addressed <$> getForwardAddr <*> get
+    get = do saddr <- getForwardAddr
+             a <- get
+             case sockAddrPort saddr of
+                Just 0 -> return $ TCPIndex (addrToIndex saddr) a
+                _      -> return $ Addressed saddr a
     put (Addressed addr x) = putForwardAddr addr >> put x
+    put (TCPIndex  idx  x) = putForwardAddr (indexToAddr idx) >> put x
 
 data N0
 data S n
@@ -529,31 +548,55 @@ instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Fo
     get = Forwarding <$> getPublicKey <*> get
     put (Forwarding k x) = putPublicKey k >> put x
 
+rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)),
+                 Serialize (ReturnPath n),
+                 Serialize
+                   (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) =>
+                TransportCrypto
+                -> (forall x. x -> Addressed x)
+                -> OnionRequest n
+                -> IO (Either String (OnionRequest (S n), SockAddr))
+rewrap crypto saddr (OnionRequest nonce msg rpath) = do
+    (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
+                                      <*> transportNewNonce crypto )
+    peeled <- peelOnion crypto nonce msg
+    return $ peeled >>= \case
+        Addressed dst msg'
+          -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst)
+        _ -> Left "Onion forward to TCP client?"
+
 handleOnionRequest :: forall a proxy n.
                       ( LessThanThree n
                       , KnownPeanoNat n
                       , Sized (ReturnPath n)
                       , Typeable n
-                      ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
+                      ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a
 handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
     let n = peanoVal rpath
     dput XOnion $ "handleOnionRequest " ++ show n
     (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
                                       <*> transportNewNonce crypto )
     peeled <- peelOnion crypto nonce msg
+    let showDestination = case saddr () of
+            Addressed a _ -> either show show $ either4or6 a
+            TCPIndex  i _ -> "TCP" ++ show [i]
+
     case peeled of
         Left e -> do
             -- todo report encryption error
-            dput XOnion $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
+            dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
             kont
         Right (Addressed dst msg') -> do
-            dput XOnion $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
+            dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"]
             sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
             kont
+        Right (TCPIndex {}) -> do
+            dput XUnexpected "handleOnionRequest: Onion forward to TCP client?"
+            kont
 
 wrapSymmetric :: Serialize (ReturnPath n) =>
-                 SymmetricKey -> Nonce24 -> SockAddr -> ReturnPath n -> ReturnPath (S n)
-wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ Addressed saddr rpath)
+                 SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n)
+wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath)
 
 peelSymmetric :: Serialize (Addressed (ReturnPath n))
                  => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
@@ -568,8 +611,16 @@ peelOnion :: Serialize (Addressed (Forwarding n t))
 peelOnion crypto nonce (Forwarding k fwd) = do
     fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
 
-handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n)) => proxy (S n) -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionResponse (S n) -> IO a
-handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do
+handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n), Typeable n) =>
+                        proxy (S n)
+                        -> TransportCrypto
+                        -> SockAddr
+                        -> UDPTransport
+                        -> (Int -> OnionResponse N1 -> IO ()) -- ^ TCP-relay onion send.
+                        -> IO a
+                        -> OnionResponse (S n)
+                        -> IO a
+handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do
     sym <- atomically $ transportSymmetric crypto
     case peelSymmetric sym path of
         Left e -> do
@@ -580,6 +631,12 @@ handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do
         Right (Addressed dst path') -> do
             sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
             kont
+        Right (TCPIndex dst path') -> do
+            -- This should only occur for OnionResponse N1
+            case gcast (OnionResponse path' msg) of
+                Just supported -> sendTCP dst supported
+                Nothing        -> dput XUnexpected "handleOnionResponse: TCP-bound message not supported."
+            kont
 
 
 data AnnounceRequest = AnnounceRequest
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
index 0b03ed19..0b34e8f8 100644
--- a/src/Network/Tox/Transport.hs
+++ b/src/Network/Tox/Transport.hs
@@ -22,14 +22,15 @@ toxTransport ::
           -> OnionRouter
           -> (PublicKey -> IO (Maybe NodeInfo))
           -> UDPTransport
+          -> (Int -> OnionResponse N1 -> IO ()) -- ^ TCP-bound callback.
           -> IO ( Transport String SockAddr (CryptoPacket Encrypted)
                 , Transport String NodeInfo (DHTMessage Encrypted8)
                 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
                 , Transport String AnnouncedRendezvous (PublicKey,OnionData)
                 , Transport String SockAddr (Handshake Encrypted))
-toxTransport crypto orouter closeLookup udp = do
+toxTransport crypto orouter closeLookup udp tcp = do
     (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
-    (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp0
+    (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp0 tcp
     (onion1,udp2) <- partitionTransportM (parseOnionAddr $ lookupSender orouter)
                                         (encodeOnionAddr crypto $ lookupRoute orouter)
                                         udp1