Schedule TCP chat-link session attempts.

5 files changed, 52 insertions, 18 deletions

diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs
index 00e7146b..c4440409 100644
--- a/dht/ToxManager.hs
+++ b/dht/ToxManager.hs
@@ -277,6 +277,11 @@ nodeinfoStaleTime = 600 -- consider DHT node address stale after 10 minutes
 nodeinfoSearchInterval :: POSIXTime
 nodeinfoSearchInterval = 15 -- when no address, search DHT node every 15 seconds
 
+
+cycled :: [x] -> [x]
+cycled []     = []
+cycled (x:xs) = xs ++ [x]
+
 connectViaRelay :: ToxToXMPP -> PublicKey -> Tox.DHTPublicKey
                    -> Announcer -> AnnounceKey -> POSIXTime -> STM (IO ())
 connectViaRelay tx theirKey theirDhtKey ann tkey now = do
@@ -287,15 +292,28 @@ connectViaRelay tx theirKey theirDhtKey ann tkey now = do
             established <- activeSesh tx theirKey
             return $ when (not established) go
  where
+    myPublicKey = toPublic $ userSecret (txAccount tx)
+    me = key2id myPublicKey
+    tkey = akeyConnectTCP (txAnnouncer tx) me theirKey
     go = do
         let Tox.SendNodes ns = Tox.dhtpkNodes theirDhtKey
         mcon <- foldr (\action next -> action >>= maybe next (return . Just))
                       (return Nothing)
-                    $ map (\ni -> fmap ((,) ni) <$> TCP.tcpConnectionRequest (txTCP tx) theirKey ni) ns
-        forM_ mcon $ \(con,ni) -> do
-            return ()
-            -- TODO: try connect tcp relays
-            -- TODO: cookie;handshake
+                    $ map (Multi.tcpConnectionRequest (txTCP tx) theirKey) ns
+        forM_ mcon $ \ni -> do
+          cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case
+            Nothing -> return ()
+            Just cookie -> do
+                cookieCreationStamp <- getPOSIXTime
+                let their_nid = key2id $ dhtpk theirDhtKey
+                dput XNetCrypto $ show their_nid ++ " --> cookie (TCP)"
+                hs <- cacheHandshake (toxHandshakeCache $ txTox tx) (userSecret (txAccount tx)) theirKey ni cookie
+                dput XNetCrypto $  show their_nid ++ "<-- handshake " ++ show (key2id theirKey) ++ " (TCP)"
+                sendMessage (toxHandshakes $ txTox tx) (Multi.sessionAddr ni) hs
+        atomically $ do
+            -- Try again in 5 seconds.
+            let theirDhtKey' = theirDhtKey' { Tox.dhtpkNodes = Tox.SendNodes (cycled ns) }
+            scheduleRel ann tkey (ScheduledItem $ connectViaRelay tx theirKey theirDhtKey') 5
 
 gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
 gotDhtPubkey theirDhtKey tx theirKey = do
@@ -318,7 +336,7 @@ gotDhtPubkey theirDhtKey tx theirKey = do
           tkey = akeyConnectTCP (txAnnouncer tx) me theirKey
       atomically $ registerNodeCallback (toxRouting tox) (nic akey)
       scheduleSearch (txAnnouncer tx) akey meth theirDhtKey
-      -- TODO atomically $ scheduleImmediately (txAnnouncer tx) tkey $ ScheduledItem $ connectViaRelay tx theirKey theirDhtKey
+      atomically $ scheduleImmediately (txAnnouncer tx) tkey $ ScheduledItem $ connectViaRelay tx theirKey theirDhtKey
 
     target :: NodeId
     target = key2id $ dhtpk theirDhtKey
@@ -394,6 +412,9 @@ activeSesh tx theirKey = do
                         Just False -> return False
                         _          -> (== Established) <$> aggregateStatus c
 
+cookieMaxAge :: POSIXTime
+cookieMaxAge = 60 * 5
+
 getCookie
       :: ToxToXMPP
       -> PublicKey
@@ -428,8 +449,6 @@ getCookie tx theirKey theirDhtKey ni isActive getC ann akey now = getCookieAgain
     reschedule n f = scheduleRel ann akey f n
     reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
 
-    cookieMaxAge = 60 * 5
-
     getCookieIO :: IO ()
     getCookieIO = do
           dput XNetCrypto $ show addr ++ " <-- request cookie"
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index bd12821a..c01d50cd 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -1634,7 +1634,7 @@ initJabber :: Options
               -> Map.Map String DHT
               -> MUC
               -> IO ( Maybe XMPPServer
-                    , Maybe (Manager TCPStatus T.Text)
+                    , Maybe ConnectionManager -- (Manager (Either Pending TCPStatus) (Either T.Text T.Text))
                     , Maybe (PresenceState Pending)
                     , IO () -- quit chat thread
                     )
@@ -1666,7 +1666,10 @@ initJabber opts ssvar announcer mbtox toxdhts toxchat = case portxmpp opts of
             let chats = Map.fromList [ ("local", chat)
                                      , ("ngc", toxchat) ]
             xmpp_thread <- forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport))
-            conns     <- xmppConnections  sv
+            let conns :: ConnectionManager -- Manager (Either Pending TCPStatus) (Either T.Text T.Text)
+                conns = fromMaybe (ConnectionManager tcp) $ do
+                    sel <- tman
+                    Just $ ConnectionManager $ addManagers (selectManager (Just sel) tcp "auto.tox") tcp
             return (Just sv, Just conns, Just state, killThread xmpp_thread >> quitChatService)
 
 main :: IO ()
@@ -1818,7 +1821,7 @@ main = do
                 , toxkeys           = keysdb
                 , roster            = rstr
                 , announceToLan     = fromMaybe (return ()) $ Tox.toxAnnounceToLan <$> mbtox
-                , connectionManager = ConnectionManager <$> mconns
+                , connectionManager = mconns
                 , onionRouter       = orouter
                 , externalAddresses = liftM2 (++) btips toxips
                 , announcer         = announcer
diff --git a/dht/src/Data/Tox/DHT/Multi.hs b/dht/src/Data/Tox/DHT/Multi.hs
index 3f91387c..f769e384 100644
--- a/dht/src/Data/Tox/DHT/Multi.hs
+++ b/dht/src/Data/Tox/DHT/Multi.hs
@@ -7,13 +7,14 @@
 {-# LANGUAGE TypeFamilies          #-}
 module Data.Tox.DHT.Multi where
 
+import Crypto.PubKey.Curve25519 (PublicKey)
 import qualified Network.Tox.NodeId as UDP
          ;import Network.Tox.NodeId (NodeId)
 import qualified Network.Tox.TCP.NodeId as TCP
-import Data.Tox.Relay
+import Data.Tox.Relay hiding (NodeInfo)
 import Network.Address (either4or6)
-import Network.Tox.TCP as TCP (ViaRelay(..))
-import Network.QueryResponse (Tagged(..))
+import Network.Tox.TCP as TCP (ViaRelay(..), tcpConnectionRequest_)
+import Network.QueryResponse as QR (Tagged(..), Client)
 
 import Data.Dependent.Sum
 import Data.GADT.Compare
@@ -124,3 +125,13 @@ relayNodeId (ViaRelay _ nid _) = nid
 udpNode :: DSum T Identity -> Maybe UDP.NodeInfo
 udpNode (UDP :=> Identity ni) = Just ni
 udpNode _                     = Nothing
+
+sessionAddr :: DSum T Identity -> DSum S Identity
+sessionAddr (UDP :=> Identity ni) = SessionUDP ==> UDP.nodeAddr ni
+sessionAddr (TCP :=> Identity vr) = SessionTCP ==> vr
+
+tcpConnectionRequest :: QR.Client err PacketNumber tid TCP.NodeInfo (Bool, RelayPacket)
+                        -> PublicKey -> TCP.NodeInfo -> IO (Maybe NodeInfo)
+tcpConnectionRequest client pubkey ni = do
+    mcon <- tcpConnectionRequest_ client pubkey ni
+    return $ fmap (\conid -> TCP ==> ViaRelay (Just conid) (UDP.key2id pubkey) ni) mcon
diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs
index e19f71b6..a9bc4e1d 100644
--- a/dht/src/Data/Tox/Onion.hs
+++ b/dht/src/Data/Tox/Onion.hs
@@ -125,12 +125,12 @@ data OnionDestination r
     = OnionToOwner
         { onionNodeInfo   :: NodeInfo
         , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us.
-        }
+        } -- ^ incoming queries and outgoing responses
     | OnionDestination
         { onionAliasSelector' :: AliasSelector
         , onionNodeInfo       :: NodeInfo
         , onionRouteSpec      :: Maybe r    -- ^ Our own onion-path.
-        }
+        } -- ^ outgoing queries and incoming responses
     deriving Show
 
 onionAliasSelector :: OnionDestination r -> AliasSelector
@@ -213,6 +213,7 @@ putOnionMsg (OnionToRoute pubkey          a) = putOnionAsymm 0x85 (putPublicKey
 putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
 putOnionMsg (OnionToRouteResponse         a) = putOnionAsymm 0x86 (return ()) a
 
+-- | /r/ parameter for 'OnionDestination'
 newtype RouteId = RouteId Int
  deriving Show
 
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index dc4c9967..c4727a20 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -292,9 +292,9 @@ tcpPing client dst = do
                 , method         = PingPacket
                 }
 
-tcpConnectionRequest :: Client err PacketNumber tid addr (Bool, RelayPacket)
+tcpConnectionRequest_ :: Client err PacketNumber tid addr (Bool, RelayPacket)
                         -> PublicKey -> addr -> IO (Maybe ConId)
-tcpConnectionRequest client pubkey ni = do
+tcpConnectionRequest_ client pubkey ni = do
     sendQuery client meth pubkey ni
  where
     meth = MethodSerializer