From 3ebd7ae11d7a86798b31bdb17af9797ba5e09f1d Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 27 Nov 2019 22:28:37 -0500 Subject: TCP Relay: use same crypto keys as Tox UDP node. --- dht/examples/dhtd.hs | 8 +++++--- dht/examples/testTox.hs | 3 ++- dht/examples/toxrelay.hs | 12 ++++++++++-- dht/src/Network/Tox.hs | 32 +++++++++++++++++--------------- dht/src/Network/Tox/Relay.hs | 39 ++++++++++++++++++++++++++++++++------- dht/src/Network/Tox/TCP.hs | 25 ++++++++++++++++++------- 6 files changed, 84 insertions(+), 35 deletions(-) (limited to 'dht') diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs index 68c847c5..5f0eead8 100644 --- a/dht/examples/dhtd.hs +++ b/dht/examples/dhtd.hs @@ -698,7 +698,7 @@ clientSession s@Session{..} sock cnum h = do tcnt <- readTVar $ setCount t icnt <- HashMap.size <$> readTVar (setIDs t) return (ts,tcnt,icnt) - (ts,tcnt,icnt) <- trampstate (trampolinesUDP onionRouter) + (uts,tcnt,icnt) <- trampstate (trampolinesUDP onionRouter) (tts,ttcnt,ticnt) <- trampstate (trampolinesTCP onionRouter) rs <- getAssocs (pendingRoutes onionRouter) pqs <- readTVar (pendingQueries onionRouter) @@ -718,9 +718,10 @@ clientSession s@Session{..} sock cnum h = do then show routeVersion else show routeVersion ++ "(pending)" ] | otherwise = [show n, "error!","","",""] + -- otherwise = [show n, "error!",show (IntMap.lookup n rm),show (IntMap.null rm),""] r = map (uncurry showRecord) rs return $ do - hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size ts,tcnt,icnt) + hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size uts,tcnt,icnt) ++ if tcpmode then "" else " *" , "trampolines(TCP): " ++ show (IntMap.size tts,ttcnt,ticnt) ++ if tcpmode then " *" else "" @@ -1377,12 +1378,13 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of [""] -> return (Nothing,return (), Map.empty, return [],[]) toxport -> do dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) + crypto <- Tox.newToxCrypto (dhtkey opts) tox <- Tox.newTox keysdb toxport (case mbxmpp of Nothing -> \_ _ _ -> return () Just xmpp -> onNewToxSession xmpp ssvar invc) - (dhtkey opts) + crypto (\_ _ -> return ()) -- TODO: TCP relay send -- addrTox <- getBindAddress toxport (ip6tox opts) (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox (advertiseOnAvahi opts) diff --git a/dht/examples/testTox.hs b/dht/examples/testTox.hs index 67c4daef..57601422 100644 --- a/dht/examples/testTox.hs +++ b/dht/examples/testTox.hs @@ -42,10 +42,11 @@ makeToxNode :: UDPTransport -> Maybe SecretKey -> IO (Tox extra) makeToxNode udp sec onSessionF = do keysdb <- newKeysDatabase + crypto <- newToxCrypto sec newToxOverTransport keysdb (SockAddrInet 0 0) onSessionF - sec + crypto udp (\_ _ -> return ()) diff --git a/dht/examples/toxrelay.hs b/dht/examples/toxrelay.hs index af08e8d7..d6b0da17 100644 --- a/dht/examples/toxrelay.hs +++ b/dht/examples/toxrelay.hs @@ -1,15 +1,23 @@ -import Network.Address (getBindAddress) +import Network.Address (getBindAddress,sockAddrPort) import Network.SocketLike import Network.StreamServer import Network.Tox.Onion.Transport hiding (encrypt,decrypt) import Network.Tox.Relay +import Crypto.Tox + +import DPut +import DebugTag + +socketPort s = sockAddrPort <$> getSocketName s main :: IO () main = do udp_addr <- getBindAddress "33445" True let sendOnion :: SockAddr -> OnionRequest N1 -> IO () sendOnion _ _ = return () - (h,sendTCP) <- tcpRelay udp_addr sendOnion + setVerbose XNetCrypto + crypto <- newCrypto + (h,sendTCP) <- tcpRelay crypto udp_addr sendOnion boundPort <- socketPort $ listenSocket h putStrLn $ "Listening on port: " ++ show boundPort 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 } -- cgit v1.2.3