2 files changed, 50 insertions, 14 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)
 
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 13da804f..ca4ca817 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -48,7 +48,8 @@ import Network.Tox.DHT.Handlers (toxSpace)
 import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
 import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
 import qualified Network.Tox.NodeId as UDP
-
+import Text.XXD
+import Data.Proxy
 
 withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
 withSize f = case size of len -> f len
@@ -89,14 +90,23 @@ tcpStream crypto = StreamHandshake
         noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
         dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
         hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
-        welcomeE <- withSize $ fmap decode . hGet h . constSize
+        (welcomeE, wbs) <- do
+            let sz0 = size
+                sz = constSize sz0
+            bs <- hGet h sz
+            return ( fmap (`asProxyTypeOf` sz0) $ decode bs, bs )
         let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
             nil = SessionProtocol
                 { streamGoodbye = return ()
                 , streamDecode = return Nothing
                 , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y
                 }
-        either (\_ -> return nil) id $ mwelcome <&> \welcome -> do
+        either (\e -> do
+                        dput XTCP $ "welcome: " ++ show (Data.ByteString.length wbs) ++ " bytes."
+                        forM_ (xxd2 0 wbs) $ dput XTCP
+                        dput XTCP $ "TCP(fail welcome): " ++ e
+                        return nil
+                ) id $ mwelcome <&> \welcome -> do
         dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
         noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
         nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
@@ -118,6 +128,7 @@ tcpStream crypto = StreamHandshake
                                     dput XTCP $ "TCP: Failed to decode packet."
                                     return Nothing
                                 Right x -> do
+                                    dput XTCP $ "TCP:"++ show addr ++ " --> packet!"
                                     m24 <- timeout 1000000 (takeMVar nread)
                                     fmap join $ forM m24 $ \n24 -> do
                                         let r = decrypt (noncef' n24) x >>= decodePlain
@@ -133,16 +144,16 @@ tcpStream crypto = StreamHandshake
                                         dput XTCP $ "TCP exception: " ++ show e
                                         return Nothing
             , streamEncode = \y -> do
-                dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
+                -- dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
                 n24 <- takeMVar nsend
-                dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
+                -- dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
                 let bs = encode $ encrypt (noncef' n24) $ encodePlain y
                 ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
                     $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
                                 `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
-                dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
+                -- dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
                 putMVar nsend (incrementNonce24 n24)
-                dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y
+                dput XTCP $ "TCP: " ++ show addr ++ " <-- " ++ show y
             }
     , streamAddr = nodeAddr
     }