Handle out-of-band netcrypto handshake.

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