WIP: Support for sending onion queries to TCP relays.

1 files changed, 47 insertions, 9 deletions

diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index ef74b9c6..6e2a42c5 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                        #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveFoldable             #-}
 {-# LANGUAGE DeriveFunctor              #-}
@@ -32,6 +33,7 @@ import qualified Data.ByteString              as B
          ;import Data.ByteString              (ByteString)
 import qualified Data.ByteString.Char8        as C8
 import Data.Data
+import Data.Functor.Identity
 import Data.Functor.Contravariant
 import Data.Maybe
 import qualified Data.MinMaxPSQ               as MinMaxPSQ
@@ -42,6 +44,7 @@ import Network.Socket
 import System.Endian
 import System.IO.Error
 
+import qualified Data.Word64Map
 import Network.BitTorrent.DHT.Token           as Token
 import qualified Data.Wrapper.PSQ             as PSQ
 import System.Global6
@@ -68,6 +71,7 @@ import DebugTag
 import TCPProber
 import Network.Tox.Avahi
 import Network.Tox.Session
+import qualified Data.Tox.Relay as TCP
 import Network.Tox.Relay
 import Network.SessionTransports
 import Network.Kademlia.Search
@@ -238,6 +242,37 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
             _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
     return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
 
+newOnionClient :: DRG g =>
+                        TransportCrypto
+                        -> Transport String (Onion.OnionDestination RouteId) Onion.Message
+                        -> DHT.Routing
+                        -> TVar SessionTokens
+                        -> TVar Onion.AnnouncedKeys
+                        -> OnionRouter
+                        -> TVar (g, Data.Word64Map.Word64Map a)
+                        -> (MVar Onion.Message -> a)
+                        -> (a -> Onion.Message -> IO void)
+                        -> Client String
+                                  DHT.PacketKind
+                                  DHT.TransactionId
+                                  (Onion.OnionDestination RouteId)
+                                  Onion.Message
+newOnionClient crypto net r toks keydb orouter map_var store load = Client
+    { clientNet = net
+    , clientDispatcher = DispatchMethods
+        { classifyInbound = Onion.classify
+        , lookupHandler   = Onion.handlers net r toks keydb
+        , tableMethods = hookQueries orouter DHT.transactionKey
+                         $ transactionMethods' store load (contramap w64Key w64MapMethods) gen
+        }
+    , clientErrorReporter = logErrors { reportTimeout = reportTimeout ignoreErrors }
+    , clientPending = map_var
+    , clientAddress = getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 r)
+    , clientResponseId = genNonce24 map_var
+    , clientEnterQuery = \_ -> return ()
+    , clientLeaveQuery = \_ _ -> return ()
+    }
+
 newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rendezvous for.
        -> [String]                   -- ^ Bind-address to listen on. Must provide at least one.
        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
@@ -287,8 +322,11 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
     let lookupClose _ = return Nothing
 
     mkrouting <- DHT.newRouting addr crypto updateIP updateIP
-    orouter <- newOnionRouter crypto $ dput XRoutes
-    (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp tcp
+    (orouter,otbl) <- newOnionRouter crypto (dput XRoutes)
+    (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes)
+        <- toxTransport crypto orouter lookupClose udp
+                (sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter))
+                tcp
     sessions <- initSessions (sendMessage cryptonet)
 
     let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
@@ -296,7 +334,7 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
         tbl6 = DHT.routing6 $ mkrouting (error "missing client")
         updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr
     dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
-                    $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net
+                    (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)
 
     hscache <- newHandshakeCache crypto (sendMessage handshakes)
     let sparams = SessionParams
@@ -315,13 +353,13 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
     toks <- do
         nil <- nullSessionTokens
         atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
-    oniondrg <- drgNew
     let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
-    onionclient <- newClient oniondrg onionnet (const Onion.classify)
-                    (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient))
-                    (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb)
-                    (hookQueries orouter' DHT.transactionKey)
-                    (const id)
+    let onionclient  = newOnionClient crypto onionnet (mkrouting dhtclient) toks keydb orouter' otbl
+                        Right $ \case
+                            Right v -> tryPutMVar v
+                            Left v  -> \_ -> do
+                                dput XUnexpected "TCP-sent onion query got response over UDP?"
+                                return False
 
     return Tox
         { toxDHT            = dhtclient