Onion: Support for forwarding from a TCP-relay.

4 files changed, 89 insertions, 29 deletions

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