WIP: Support for sending onion queries to TCP relays.

1 files changed, 17 insertions, 40 deletions

diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
index e3f5012b..1111d3b8 100644
--- a/src/Network/Tox/TCP.hs
+++ b/src/Network/Tox/TCP.hs
@@ -2,7 +2,10 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE FlexibleContexts #-}
-module Network.Tox.TCP where
+module Network.Tox.TCP
+    ( module Network.Tox.TCP
+    , NodeInfo(..)
+    ) where
 
 import Control.Arrow
 import Control.Concurrent
@@ -46,11 +49,6 @@ 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
 
-data NodeInfo = NodeInfo
-    { udpNodeInfo :: UDP.NodeInfo
-    , tcpPort     :: PortNumber
-    }
- deriving (Eq,Ord)
 
 type NodeId = UDP.NodeId
 
@@ -59,36 +57,6 @@ type NodeId = UDP.NodeId
 instance Show NodeInfo where
     show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}"
 
-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)
-
 nodeId :: NodeInfo -> NodeId
 nodeId ni = UDP.nodeId $ udpNodeInfo ni
 
@@ -275,12 +243,21 @@ tcpPing client dst = sendQuery client meth () dst
 
 type RelayClient = Client String () Nonce8 NodeInfo RelayPacket
 
-newClient :: TransportCrypto -> IO RelayClient
-newClient crypto = do
+-- | 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
+               -> (MVar RelayPacket -> a)       -- ^ store mvar for query
+               -> (a -> RelayPacket -> IO void) -- ^ load mvar for query
+               -> IO ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
+                     , Client String () Nonce8 NodeInfo RelayPacket)
+newClient crypto store load = do
     net <- toxTCP crypto
     drg <- drgNew
     map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
-    return Client
+    return $ (,) map_var Client
         { clientNet = net
         , clientDispatcher = DispatchMethods
             { classifyInbound = \case
@@ -294,7 +271,7 @@ newClient crypto = do
                     , methodSerialize = \n8 src dst () -> RelayPong n8
                     , methodAction    = \src () -> return ()
                     }
-            , tableMethods = transactionMethods (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
+            , tableMethods = transactionMethods' store load (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
                                 $ first (either error Nonce8 . decode) . randomBytesGenerate 8
             }
         , clientErrorReporter = logErrors