TCP Relay: use same crypto keys as Tox UDP node.

3 files changed, 67 insertions, 29 deletions

diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 97b97bad..69c56e24 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -278,10 +278,10 @@ newOnionClient crypto net r toks keydb orouter map_var store load = c
 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 () )
-       -> Maybe SecretKey            -- ^ Optional DHT secret key to use.
-        -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
+       -> (TransportCrypto, ContactInfo extra)
+       -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
        -> IO (Tox extra)
-newTox keydb bindspecs onsess suppliedDHTKey tcp = do
+newTox keydb bindspecs onsess crypto tcp = do
     addrs <- mapM (`getBindAddress` True) bindspecs
     let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just)
         failedBind mbe = do
@@ -291,21 +291,14 @@ newTox keydb bindspecs onsess suppliedDHTKey tcp = do
             throwIO $ userError "Tox UDP listen port?"
     (udp,sock) <- foldr tryBind failedBind addrs Nothing
     addr <- getSocketName sock
-    (relay,sendTCP) <- tcpRelay addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x)
-    tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp sendTCP
+    (relay,sendTCP) <- tcpRelay (fst crypto) addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x)
+    tox <- newToxOverTransport keydb addr onsess crypto udp sendTCP
     return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox)
                , toxRelayServer   = Just relay
                }
 
--- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
-newToxOverTransport :: TVar Onion.AnnouncedKeys
-        -> SockAddr
-        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
-        -> Maybe SecretKey
-        -> Onion.UDPTransport
-        -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
-        -> IO (Tox extra)
-newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
+newToxCrypto :: Maybe SecretKey -> IO (TransportCrypto, ContactInfo extra)
+newToxCrypto suppliedDHTKey = do
     roster <- newContactInfo
     crypto0 <- newCrypto
     let -- patch in supplied DHT key
@@ -316,12 +309,21 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
                 , transportPublic = toPublic k
                 }
         -- patch in newly allocated roster state.
-        crypto = crypto1 { userKeys = myKeyPairs roster }
     forM_ suppliedDHTKey $ \k -> do
         maybe (dput XMisc "failed to encode suppliedDHTKey")
               (dputB XMisc . C8.append "Using suppliedDHTKey: ")
               $ encodeSecret k
+    return (crypto1 { userKeys = myKeyPairs roster }, roster )
 
+-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
+newToxOverTransport :: TVar Onion.AnnouncedKeys
+        -> SockAddr
+        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
+        -> (TransportCrypto, ContactInfo extra)
+        -> Onion.UDPTransport
+        -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
+        -> IO (Tox extra)
+newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
     drg <- drgNew
     let lookupClose _ = return Nothing
 
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
     }