WIP: Support for sending onion queries to TCP relays.

1 files changed, 46 insertions, 1 deletions

diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
index 02300866..d1e9fb99 100644
--- a/src/Data/Tox/Relay.hs
+++ b/src/Data/Tox/Relay.hs
@@ -8,16 +8,24 @@
 {-# LANGUAGE UndecidableInstances       #-}
 module Data.Tox.Relay where
 
+import Data.Aeson (ToJSON(..),FromJSON(..))
+import qualified Data.Aeson as JSON
 import Data.ByteString as B
 import Data.Data
 import Data.Functor.Contravariant
+import Data.Hashable
+import qualified Data.HashMap.Strict as HashMap
 import Data.Monoid
 import Data.Serialize
+import qualified Data.Vector as Vector
 import Data.Word
+import Network.Socket
 import qualified Rank2
+import qualified Text.ParserCombinators.ReadP as RP
 
 import Crypto.Tox
-import Network.Tox.Onion.Transport
+import Data.Tox.Onion
+import qualified Network.Tox.NodeId as UDP
 
 newtype ConId = ConId Word8
     deriving (Eq,Show,Ord,Data,Serialize)
@@ -178,3 +186,40 @@ instance Sized (Welcome Encrypted) where
 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.
+
+instance FromJSON NodeInfo where
+    parseJSON json = do
+        udp <- parseJSON json
+        port <- case json of
+            JSON.Object v -> do
+                portnum:_ <- v JSON..: "tcp_ports"
+                return  (fromIntegral (portnum :: Word16))
+            _ -> fail "TCP.NodeInfo: Expected JSON object."
+        return $ NodeInfo udp port
+
+instance Hashable NodeInfo where
+    hashWithSalt s n = hashWithSalt s (udpNodeInfo n)
+