1 files changed, 32 insertions, 7 deletions

diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs
index 2842fcc2..2ecd7ddf 100644
--- a/dht/src/Network/Tox/Relay.hs
+++ b/dht/src/Network/Tox/Relay.hs
@@ -30,6 +30,8 @@ import Network.SocketLike
 import Network.StreamServer
 import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
 
+import DPut
+import DebugTag
 
 
 hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
@@ -43,6 +45,7 @@ hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF
  where
     ConstSize len = size :: Size x
 
+-- This type manages ConId assignments.
 data RelaySession = RelaySession
     { indexPool  :: IntSet                                   -- ^ Ints that are either solicited or associated.
     , solicited  :: Map PublicKey Int                        -- ^ Reserved ids, not yet in associated.
@@ -70,17 +73,19 @@ disconnect cons who = join $ atomically $ do
                      in IntMap.foldrWithKey notifyPeer (return ()) cs
 
 relaySession :: TransportCrypto
+                -> TVar (IntMap (RelayPacket -> IO ()))
                 -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
                 -> (SockAddr -> OnionRequest N1 -> IO ())
                 -> sock
                 -> Int
                 -> Handle
                 -> IO ()
-relaySession crypto cons sendOnion _ conid h = do
+relaySession crypto clients cons sendOnion _ conid h = do
     -- atomically $ modifyTVar' cons $ IntMap.insert conid h
 
     -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h
 
+    dput XOnion $ "Relay client session conid=" ++ show conid
     (hGetSized h >>=) $ mapM_ $ \helloE -> do
 
     let me = transportSecret crypto
@@ -88,17 +93,24 @@ relaySession crypto cons sendOnion _ conid h = do
 
     noncef <- lookupNonceFunction crypto me them
     let mhello = decryptPayload (noncef $ helloNonce helloE) helloE
+    dput XOnion $ "Relay client (conid=" ++ show conid ++ ") decrypted hello = " ++ show mhello
     forM_ mhello $ \hello -> do
         let _ = hello :: Hello Identity
 
+        dput XOnion $ "Relay client sent hello. conid=" ++ show conid
         (me',welcome) <- atomically $ do
             skey <- transportNewKey crypto
             dta <- HelloData (toPublic skey) <$> transportNewNonce crypto
             w24 <- transportNewNonce crypto
             return (skey, Welcome w24 $ pure dta)
 
+        dput XOnion $ unlines [ "Relay client to receive welcome. conid=" ++ show conid
+                              , show welcome
+                              ]
         B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
 
+        dput XOnion $ "Relay client welcome sent. conid=" ++ show conid
+
         noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
                    in lookupNonceFunction crypto me' them'
 
@@ -133,13 +145,20 @@ relaySession crypto cons sendOnion _ conid h = do
 
             handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
 
+            atomically $ modifyTVar' clients $ IntMap.insert conid $
+                \p -> do
+                    dput XOnion $ "Sending onion reply to TCP client conid="++show conid
+                    sendPacket p
+
             flip fix (incrementNonce24 base)  $ \loop n24 -> do
                 m <- readPacket n24
                 forM_ m $ \p -> do
                     handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
                     loop (incrementNonce24 n24)
-         `finally`
+         `finally` do
+            atomically $ modifyTVar' clients $ IntMap.delete conid
             disconnect cons (helloFrom hello)
+            dput XOnion $ "Relay client session closed. conid=" ++ show conid
 
 handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
                       -> Int
@@ -202,6 +221,7 @@ handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
             return $ sendToThem' $ RelayData bs
 
     OnionPacket n24 (Addressed addr req) -> do
+        dput XOnion $ "Received onion request via TCP client conid="++show thistcp
         rpath <- atomically $ do
                     sym <- transportSymmetric crypto
                     n <- transportNewNonce crypto
@@ -217,19 +237,24 @@ sendTCP_ st addr x = join $ atomically
         Nothing   -> return $ return ()
         Just send -> return $ send $ OnionPacketResponse x
 
-tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ())
-tcpRelay udp_addr sendOnion = do
-    crypto <- newCrypto
+tcpRelay :: TransportCrypto
+            -> SockAddr -- ^ UDP bind address (this port may be tried for TCP if hardcoded defaults dont work).
+            -> (SockAddr -> OnionRequest N1 -> IO ()) -- ^ This callback will be used to forward onion messages over udp.
+            -> IO ( ServerHandle -- Handle to the Tox Tcp-Relay server.
+                  , Int -> OnionMessage Encrypted -> IO () -- forward onion response to tcp client.
+                  )
+tcpRelay crypto udp_addr sendOnion = do
     cons <- newTVarIO Map.empty
     clients <- newTVarIO IntMap.empty
     b443   <- getBindAddress "443"   True
     b80    <- getBindAddress "80"    True
+    b3389  <- getBindAddress "3389"  True
     b33445 <- getBindAddress "33445" True
     bany   <- getBindAddress ""      True
     h <- streamServer ServerConfig
                         { serverWarn    = hPutStrLn stderr
-                        , serverSession = relaySession crypto cons sendOnion
+                        , serverSession = relaySession crypto clients cons sendOnion
                         }
-                      [b443,b80,udp_addr,b33445,bany]
+                      [b443,b80,b3389,udp_addr,b33445,bany]
     return (h,sendTCP_ clients)