Share TCP Relays with remote via onion message.

10 files changed, 115 insertions, 37 deletions

diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal
index 19f4f2b3..24739767 100644
--- a/dht/dht-client.cabal
+++ b/dht/dht-client.cabal
@@ -98,6 +98,7 @@ library
                     Network.Tox.DHT.Transport
                     Network.Tox.Handshake
                     Network.Tox.NodeId
+                    Network.Tox.TCP.NodeId
                     Network.Tox.Avahi
                     Network.Tox.RelayPinger
                     Network.UPNP
diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs
index 258a9f73..d3c8086d 100644
--- a/dht/src/Data/Tox/Onion.hs
+++ b/dht/src/Data/Tox/Onion.hs
@@ -25,6 +25,7 @@ import Crypto.Tox hiding (encrypt,decrypt)
 import Network.Tox.NodeId
 import qualified Crypto.Tox as ToxCrypto
 import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo)
+import Network.Tox.TCP.NodeId (fromUDPNode)
 
 import Control.Applicative
 import Control.Arrow
@@ -717,7 +718,7 @@ getNodeList = do
     (:) n <$> (getNodeList <|> pure [])
 
 instance S.Serialize AnnounceResponse where
-    get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
+    get = AnnounceResponse <$> S.get <*> (SendNodes . map fromUDPNode <$> getNodeList)
     put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
 
 data DataToRoute = DataToRoute
diff --git a/dht/src/Data/Tox/Relay.hs b/dht/src/Data/Tox/Relay.hs
index f28a1685..64c90806 100644
--- a/dht/src/Data/Tox/Relay.hs
+++ b/dht/src/Data/Tox/Relay.hs
@@ -7,7 +7,10 @@
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE UndecidableInstances       #-}
-module Data.Tox.Relay where
+module Data.Tox.Relay
+    ( module Network.Tox.TCP.NodeId
+    , module Data.Tox.Relay
+    ) where
 
 import Data.Aeson (ToJSON(..),FromJSON(..))
 import qualified Data.Aeson as JSON
@@ -27,8 +30,10 @@ import qualified Rank2
 import qualified Text.ParserCombinators.ReadP as RP
 
 import Crypto.Tox
+import Network.Tox.TCP.NodeId
 import Data.Tox.Onion
 import qualified Network.Tox.NodeId as UDP
+import Network.Tox.TCP.NodeId as TCP
 
 newtype ConId = ConId Word8
     deriving (Eq,Show,Ord,Data,Serialize)
@@ -196,28 +201,6 @@ instance Serialize (Welcome Encrypted) where
     get = Welcome <$> get <*> get
     put (Welcome n dta) = put n >> put dta
 
-data NodeInfo = NodeInfo
-    { udpNodeInfo :: UDP.NodeInfo
-    , tcpPort     :: PortNumber
-    }
- deriving (Eq,Ord)
-
-instance Read NodeInfo where
-    readsPrec _ = RP.readP_to_S $ do
-        udp <- RP.readS_to_P reads
-        port <- RP.between (RP.char '{') (RP.char '}') $ do
-                    mapM_ RP.char ("tcp:" :: String)
-                    w16 <- RP.readS_to_P reads
-                    return $ fromIntegral (w16 :: Word16)
-        return $ NodeInfo udp port
-
-instance ToJSON NodeInfo where
-    toJSON (NodeInfo udp port) = case (toJSON udp) of
-        JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
-                                                        (JSON.Array $ Vector.fromList
-                                                            [JSON.Number (fromIntegral port)])
-                                                        tbl
-        x               -> x -- Shouldn't happen.
 
 tcpPortScore :: Word16 -> Word16
 tcpPortScore 443  = 0
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index c233492d..61a1d117 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -47,6 +47,7 @@ import System.IO.Error
 
 import Data.TableMethods
 import Data.Tox.Onion                        (substituteLoopback)
+import Network.Tox.RelayPinger
 import qualified Data.Word64Map
 import Network.BitTorrent.DHT.Token           as Token
 import qualified Data.Wrapper.PSQ             as PSQ
@@ -194,7 +195,8 @@ data Tox extra  = Tox
 
 -- | Create a DHTPublicKey packet to send to a remote contact.
 getContactInfo :: Tox extra -> IO DHT.DHTPublicKey
-getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
+getContactInfo Tox{toxCryptoKeys,toxRouting,toxOnionRoutes} = join $ atomically $ do
+    (rcnt,relays) <- currentRelays (tcpRelayPinger toxOnionRoutes)
     r4 <- readTVar $ DHT.routing4 toxRouting
     r6 <- readTVar $ DHT.routing6 toxRouting
     nonce <- transportNewNonce toxCryptoKeys
@@ -210,7 +212,7 @@ getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
         return DHT.DHTPublicKey
             { dhtpkNonce = timestamp
             , dhtpk      = id2key self
-            , dhtpkNodes = DHT.SendNodes $ take 4 ns
+            , dhtpkNodes = DHT.SendNodes $ take 4 $ relays ++ map TCP.fromUDPNode ns
             }
 
 isLocalHost :: SockAddr -> Bool
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index e93f565b..323d5f5e 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -7,6 +7,7 @@ module Network.Tox.DHT.Handlers where
 
 import Debug.Trace
 import Network.Tox.DHT.Transport as DHTTransport
+import Network.Tox.TCP.NodeId as TCP (fromUDPNode, udpNodeInfo)
 import Network.QueryResponse as QR hiding (Client)
 import qualified Network.QueryResponse as QR (Client)
 import Crypto.Tox
@@ -257,6 +258,7 @@ getNodesH routing addr (GetNodes nid) = do
                                       Want_IP4 -> (ks,ks6)
                                       Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
     return $ SendNodes
+           $ map fromUDPNode
            $ if null ns2 then ns1
                          else take 4 (take 3 ns1 ++ ns2)
  where
@@ -397,8 +399,9 @@ unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
 unsendNodes (DHTSendNodes asymm) = Just asymm
 unsendNodes _                    = Nothing
 
+-- XXX: map udpNodeInfo is probably not right
 unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
-unwrapNodes (SendNodes ns) = (ns,ns,Just ())
+unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ())
 
 getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
 getNodes client cbvar nid addr = do
@@ -409,10 +412,10 @@ getNodes client cbvar nid addr = do
         forM_ ns $ \n -> do
             now <- getPOSIXTime
             atomically $ do
-                mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar
+                mcbs <- HashMap.lookup (nodeId . udpNodeInfo $ n) <$> readTVar cbvar
                 forM_ mcbs $ \cbs -> do
                     forM_ cbs $ \cb -> do
-                        rumoredAddress cb now (nodeAddr addr) n
+                        rumoredAddress cb now (nodeAddr addr) (udpNodeInfo n)
     return $ fmap unwrapNodes $ join reply
 
 updateRouting :: Client -> Routing
diff --git a/dht/src/Network/Tox/DHT/Transport.hs b/dht/src/Network/Tox/DHT/Transport.hs
index b9b63165..7475b3b1 100644
--- a/dht/src/Network/Tox/DHT/Transport.hs
+++ b/dht/src/Network/Tox/DHT/Transport.hs
@@ -36,6 +36,7 @@ module Network.Tox.DHT.Transport
     ) where
 
 import Network.Tox.NodeId
+import qualified Network.Tox.TCP.NodeId as TCP
 import Crypto.Tox hiding (encrypt,decrypt)
 import qualified Crypto.Tox as ToxCrypto
 import Network.QueryResponse
@@ -315,7 +316,7 @@ newtype GetNodes = GetNodes NodeId
 instance Sized GetNodes where
     size = ConstSize 32 -- TODO This right?
 
-newtype SendNodes = SendNodes [NodeInfo]
+newtype SendNodes = SendNodes [TCP.NodeInfo]
     deriving (Eq,Ord,Show,Read)
 
 instance Sized SendNodes where
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
index 6c82ce09..8567e77d 100644
--- a/dht/src/Network/Tox/NodeId.hs
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -252,8 +252,8 @@ nodeInfoFromJSON prefer4 (JSON.Object v) = do
 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 0x82 = IPv4 <$> S.get -- TODO: TCP TOX_TCP_INET
+getIP 0x8a = IPv6 <$> S.get -- TODO: TCP TOX_TCP_INET6
 getIP x    = fail ("unsupported address family ("++show x++")")
 
 instance Sized NodeInfo where
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
index b35631a3..52dcf536 100644
--- a/dht/src/Network/Tox/Onion/Handlers.hs
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -4,6 +4,7 @@
 module Network.Tox.Onion.Handlers where
 
 import Network.Kademlia.Search
+import Network.Tox.TCP.NodeId (udpNodeInfo)
 import Network.Tox.DHT.Transport
 import Network.Tox.DHT.Handlers hiding (Message,Client)
 import Network.Tox.Onion.Transport
@@ -251,7 +252,7 @@ announceSerializer getTimeout = MethodSerializer
     }
 
 unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
-unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
+unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns0)) | let ns = map udpNodeInfo ns0
     = case is_stored of
         NotStored n32    -> ( ns , []                                                        , Just n32)
         SendBackKey k    -> ( ns , [Rendezvous k ni]                                         , Nothing )
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index e80a22d1..1531dfb4 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -44,6 +44,7 @@ import Network.Kademlia.Routing
 import Network.Kademlia.Search hiding (sendQuery)
 import Network.QueryResponse
 import Network.QueryResponse.TCP
+import Network.Tox.TCP.NodeId ()
 import Network.Tox.DHT.Handlers (toxSpace)
 import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
 import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
@@ -57,10 +58,6 @@ 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
diff --git a/dht/src/Network/Tox/TCP/NodeId.hs b/dht/src/Network/Tox/TCP/NodeId.hs
new file mode 100644
index 00000000..c218c88f
--- /dev/null
+++ b/dht/src/Network/Tox/TCP/NodeId.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE CPP #-}
+module Network.Tox.TCP.NodeId where
+
+import Crypto.Tox
+import qualified Network.Tox.NodeId as UDP
+
+import qualified Data.Aeson                   as JSON
+         ;import Data.Aeson                   (FromJSON (..), ToJSON (..))
+import Data.Functor.Contravariant
+import Data.Hashable
+import qualified Data.HashMap.Strict          as HashMap
+import qualified Data.Vector                  as Vector
+import Data.Word
+import Network.Socket
+import qualified Text.ParserCombinators.ReadP as RP
+import Data.Serialize as S
+
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+
+data NodeInfo = NodeInfo
+    { udpNodeInfo :: UDP.NodeInfo
+    , tcpPort     :: PortNumber
+    }
+ deriving (Eq,Ord)
+
+instance Read NodeInfo where
+    readsPrec _ = RP.readP_to_S $ do
+        udp <- RP.readS_to_P reads
+        port <- RP.between (RP.char '{') (RP.char '}') $ do
+                    mapM_ RP.char ("tcp:" :: String)
+                    w16 <- RP.readS_to_P reads
+                    return $ fromIntegral (w16 :: Word16)
+        return $ NodeInfo udp port
+
+instance ToJSON NodeInfo where
+    toJSON (NodeInfo udp port) = case (toJSON udp) of
+        JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
+                                                        (JSON.Array $ Vector.fromList
+                                                            [JSON.Number (fromIntegral port)])
+                                                        tbl
+        x               -> x -- Shouldn't happen.
+
+-- 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++"}"
+
+instance Sized NodeInfo where
+    size = contramap udpNodeInfo size
+
+
+getIP :: Word8 -> S.Get (Bool, IP)
+getIP 0x02 = (,) False . IPv4 <$> S.get -- UDP 4
+getIP 0x0a = (,) False . IPv6 <$> S.get -- UDP 6
+getIP 0x82 = (,) True . IPv4 <$> S.get -- TCP 4
+getIP 0x8a = (,) True . IPv6 <$> S.get -- TCP 6
+getIP x    = fail ("unsupported address family ("++show x++")")
+
+instance S.Serialize NodeInfo where
+    get = do
+        addrfam <- S.get :: S.Get Word8
+        (istcp, ip) <- getIP addrfam
+        port <- S.get :: S.Get PortNumber
+        nid <- S.get
+        let (udpport, tcpport) = if istcp
+                                    then (0, port)
+                                    else (port, 0)
+        return $ NodeInfo (UDP.NodeInfo nid ip udpport) tcpport
+
+    put (NodeInfo (UDP.NodeInfo nid ip udpport) tcpport) = do
+        if tcpport==0
+            then do
+                case ip of
+                    IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
+                    IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
+                S.put udpport
+            else do
+                case ip of
+                    IPv4 ip4 -> S.put (0x82 :: Word8) >> S.put ip4
+                    IPv6 ip6 -> S.put (0x8a :: Word8) >> S.put ip6
+                S.put tcpport
+        S.put nid
+
+fromUDPNode :: UDP.NodeInfo -> NodeInfo
+fromUDPNode ni = NodeInfo ni 0