TCP client: RoutingRequest query + cosmetic changes

1 files changed, 25 insertions, 3 deletions

diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 1531dfb4..4b3a4594 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -16,6 +16,7 @@ import Control.Monad
 import Crypto.Random
 import Data.Aeson (ToJSON(..),FromJSON(..))
 import qualified Data.Aeson as JSON
+import Data.ByteArray (withByteArray)
 import Data.Functor.Contravariant
 import Data.Functor.Identity
 import Data.Hashable
@@ -26,9 +27,11 @@ import Data.Monoid
 import Data.Serialize
 import Data.Word
 import qualified Data.Vector as Vector
+import Foreign.Storable (peek)
 import Network.Socket (SockAddr(..))
 import qualified Text.ParserCombinators.ReadP as RP
 import System.IO.Error
+import System.IO.Unsafe (unsafeDupablePerformIO)
 import System.Timeout
 
 import ControlMaybe
@@ -270,8 +273,25 @@ tcpPing client dst = do
                 , method         = PingPacket
                 }
 
+tcpConnectionRequest :: Client err PacketNumber tid addr (Bool, RelayPacket)
+                        -> PublicKey -> addr -> IO (Maybe ConId)
+tcpConnectionRequest client pubkey ni = do
+    sendQuery client meth pubkey ni
+ where
+    meth = MethodSerializer
+        { wrapQuery      = \n8 src dst pubkey -> (True,RoutingRequest pubkey)
+        , unwrapResponse = \(_,RoutingResponse cid pubkey) -> cid
+        , methodTimeout  = \dst -> return (dst,5000000)
+        , method         = RoutingRequestPacket
+        }
+
 type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
 
+keyToNonce :: PublicKey -> Nonce8
+keyToNonce k = unsafeDupablePerformIO $ withByteArray k $ \ptr -> do
+    w8 <- peek ptr
+    return $ Nonce8 w8
+
 -- | 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
@@ -291,11 +311,13 @@ newClient crypto store load = do
         { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
         , clientDispatcher = DispatchMethods
             { classifyInbound = (. snd) $ \case
-                RelayPing n           -> IsQuery PingPacket n
-                RelayPong n           -> IsResponse n
+                RelayPing n             -> IsQuery PingPacket n
+                RelayPong n             -> IsResponse n
+                RoutingRequest k        -> IsQuery RoutingRequestPacket (keyToNonce k)
+                RoutingResponse conId k -> IsResponse (keyToNonce k)
                 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
                 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
-                OOBRecv k bs          -> IsUnsolicited $ handleOOB k bs
+                OOBRecv k bs            -> IsUnsolicited $ handleOOB k bs
                 wut                   -> IsUnknown (show wut)
             , lookupHandler   = \case
                 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler