From 2a35ec75c6aaddf617d3617fc3527e2e54d5cab7 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 15 Jan 2020 22:44:17 -0500 Subject: Handle out-of-band netcrypto handshake. --- dht/HandshakeCache.hs | 14 ++++++++------ dht/src/Network/Tox.hs | 32 +++++++++++++++++++++++++++----- dht/src/Network/Tox/Session.hs | 12 ++++++------ dht/src/Network/Tox/TCP.hs | 2 +- 4 files changed, 42 insertions(+), 18 deletions(-) diff --git a/dht/HandshakeCache.hs b/dht/HandshakeCache.hs index d9ffacab..00836fc8 100644 --- a/dht/HandshakeCache.hs +++ b/dht/HandshakeCache.hs @@ -27,13 +27,15 @@ data HandshakeCache = HandshakeCache { -- Note that currently we are storing sent handshakes keyed by the -- locally issued cookie nonce. hscTable :: TVar (MinMaxPSQ' Nonce24 POSIXTime (SecretKey,HandshakeData)) - , hscSend :: Multi.SessionAddress -> Handshake Encrypted -> IO () + , hscSend :: Multi.SessionAddress -> Handshake Encrypted -> IO Multi.SessionAddress , hscCrypto :: TransportCrypto , hscPendingCookies :: TVar (Map (PublicKey,PublicKey) ()) } -newHandshakeCache :: TransportCrypto -> (Multi.SessionAddress -> Handshake Encrypted -> IO ()) -> IO HandshakeCache +newHandshakeCache :: TransportCrypto + -> (Multi.SessionAddress -> Handshake Encrypted -> IO Multi.SessionAddress) + -> IO HandshakeCache newHandshakeCache crypto send = atomically $ do tbl <- newTVar MM.empty pcs <- newTVar Map.empty @@ -49,13 +51,13 @@ getSentHandshake :: HandshakeCache -> Multi.SessionAddress -> Cookie Identity -- locally issued -> Cookie Encrypted -- remotely issued - -> IO (Maybe (SecretKey, HandshakeData)) + -> IO (Maybe (Multi.SessionAddress, (SecretKey, HandshakeData))) getSentHandshake hscache me their_addr (Cookie n24 (Identity cd)) ecookie = do now <- getPOSIXTime io <- atomically $ do m <- checkExpiry now . MM.lookup' n24 <$> readTVar (hscTable hscache) case m of - Just s -> return $ return $ Just s + Just s -> return $ return $ Just (their_addr, s) Nothing -> do let them = longTermKey cd case Multi.nodeInfo (key2id $ dhtKey cd) their_addr of @@ -64,8 +66,8 @@ getSentHandshake hscache me their_addr (Cookie n24 (Identity cd)) ecookie = do (s,hs) <- cacheHandshakeSTM hscache me them their_node ecookie now return $ do dput XNetCrypto $ "getSentHandshake sending new handshake." - hscSend hscache their_addr hs - return $ Just s + addr' <- hscSend hscache their_addr hs + return $ Just (addr', s) r <- io dput XNetCrypto $ "getSentHandshake me="++show (key2id $ toPublic me)++" their_addr="++show their_addr++" --> " ++ show r return r diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs index f136ab96..23dbfe27 100644 --- a/dht/src/Network/Tox.hs +++ b/dht/src/Network/Tox.hs @@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -72,7 +73,7 @@ import qualified Network.Tox.Onion.Transport as Onion import Network.Tox.RelayPinger import System.Global6 import Network.Tox.Transport -import Network.Tox.TCP (tcpClient) +import Network.Tox.TCP (tcpClient, ViaRelay(..)) import Network.Tox.Onion.Routes import Network.Tox.ContactInfo import Text.XXD @@ -131,7 +132,7 @@ myAddr routing4 routing6 maddr = atomically $ do a <- readTVar var return $ Multi.UDP ==> R.thisNode a -newClient :: (DRG g, Show addr, Show meth) => +newClient :: forall g addr meth x. (DRG g, Show addr, Show meth) => g -> Transport String addr x -> (Client String meth DHT.TransactionId addr x -> x @@ -160,12 +161,25 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) return $ Left (word64mapT,map_var) - let dispatch tbl var handlers client = DispatchMethods + let dispatch :: TransactionMethods tbl DHT.TransactionId addr x + -> p + -> (meth + -> Maybe (MethodHandlerA String DHT.TransactionId addr x y)) + -> Client String meth DHT.TransactionId addr x + -> DispatchMethodsA tbl String meth DHT.TransactionId addr x y + dispatch tbl var handlers client = DispatchMethods { classifyInbound = classify client , lookupHandler = handlers -- var , tableMethods = modifytbl tbl } eprinter = logErrors -- printErrors stderr + mkclient :: (TransactionMethods + (g, pending) DHT.TransactionId addr x, + TVar (g, pending)) + -> (ClientA String meth DHT.TransactionId addr x x + -> meth + -> Maybe (MethodHandlerA String DHT.TransactionId addr x x)) + -> ClientA String meth DHT.TransactionId addr x x mkclient (tbl,var) handlers = let client = Client { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net @@ -337,7 +351,15 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id (\client net -> onInbound (updateOnUDP client) net) - hscache <- newHandshakeCache crypto (sendMessage handshakes) + hscache <- newHandshakeCache crypto $ \saddr hs -> do + saddr' <- case saddr of + Multi.SessionTCP :=> Identity (ViaRelay Nothing nid relay) + -> do let relayclient = relayClient $ tcpRelayPinger orouter + msaddr <- Multi.tcpConnectionRequest relayclient (id2key nid) relay + return $ maybe saddr Multi.sessionAddr msaddr + _ -> return saddr + sendMessage handshakes saddr' hs + return saddr' let sparams = SessionParams { spCrypto = crypto , spSessions = sessions diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs index 0d89afc4..ff86e502 100644 --- a/dht/src/Network/Tox/Session.hs +++ b/dht/src/Network/Tox/Session.hs @@ -49,7 +49,7 @@ data SessionParams = SessionParams , spGetSentHandshake :: SecretKey -> Multi.SessionAddress -> Cookie Identity -> Cookie Encrypted - -> IO (Maybe (SessionKey, HandshakeData)) + -> IO (Maybe (Multi.SessionAddress, (SessionKey, HandshakeData))) -- | This method is invoked on each new session and is responsible for -- launching any threads necessary to keep the session alive. , spOnNewSession :: Session -> IO () @@ -116,18 +116,18 @@ plainHandshakeH :: SessionParams -> SecretKey -> Handshake Identity -> IO () -plainHandshakeH sp saddr skey handshake = do +plainHandshakeH sp saddr0 skey handshake = do let hd = runIdentity $ handshakeData handshake - prelude = show saddr ++ " --> " + prelude = show saddr0 ++ " --> " dput XNetCrypto $ unlines $ map (prelude ++) [ "handshake: auth=" ++ show (handshakeCookie handshake) , " : issuing=" ++ show (otherCookie hd) , " : baseNonce=" ++ show (baseNonce hd) ] - sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd) + sent <- spGetSentHandshake sp skey saddr0 (handshakeCookie handshake) (otherCookie hd) -- TODO: this is always returning sent = Nothing - dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent) - forM_ sent $ \(hd_skey,hd_sent) -> do + dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd . snd) sent) + forM_ sent $ \(saddr, (hd_skey,hd_sent)) -> do sk <- SessionKeys (spCrypto sp) hd_skey (sessionKey hd) diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs index f8ec430b..ebb15e3b 100644 --- a/dht/src/Network/Tox/TCP.hs +++ b/dht/src/Network/Tox/TCP.hs @@ -368,7 +368,7 @@ newClient :: TransportCrypto , RelayCache , Transport String ViaRelay ByteString , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) ) - , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)) + , RelayClient ) newClient crypto store load lookupSender getRoute = do (tcpcache,net0) <- toxTCP crypto (relaynet,net1) <- partitionRelay net0 -- cgit v1.2.3