wip: connect via tcp.

2 files changed, 53 insertions, 22 deletions

diff --git a/dht/HandshakeCache.hs b/dht/HandshakeCache.hs
index 61735e8a..91f5faaf 100644
--- a/dht/HandshakeCache.hs
+++ b/dht/HandshakeCache.hs
@@ -113,13 +113,13 @@ cacheHandshake hscache me them their_node ecookie = do
     dput XNetCrypto $ "cacheHandshake " ++ show (key2id them,ecookie)
     atomically $ snd <$> cacheHandshakeSTM hscache me them their_node ecookie timestamp
 
-haveCachedCookie :: HandshakeCache
+getPendingCookieFlag :: HandshakeCache
                     -> PublicKey
                     -> PublicKey
                     -> STM Bool
-haveCachedCookie hscache me them = do
+getPendingCookieFlag hscache me them = do
     m <- Map.lookup (me,them) <$> readTVar (hscPendingCookies hscache)
-    return $ maybe True (const False) m
+    return $ maybe False (const True) m
 
 
 setPendingCookie :: HandshakeCache
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs
index 96bd9bc3..ab73b327 100644
--- a/dht/ToxManager.hs
+++ b/dht/ToxManager.hs
@@ -49,6 +49,8 @@ import Network.Tox.NodeId
 import qualified Network.Tox.Onion.Handlers  as Tox
 import qualified Network.Tox.Onion.Transport as Tox
          ;import Network.Tox.Onion.Transport (OnionData (..))
+import Network.Tox.Onion.Routes (tcpKademliaClient)
+import qualified Network.Tox.TCP as TCP
 import Presence
 import Text.Read
 import Util                                  (unsplitJID)
@@ -134,7 +136,12 @@ toxman ssvar announcer toxbkts tox presence = ToxManager
                                      toxAnnounceInterval)
                      pub
 
-            forkAccountWatcher ssvar acnt tox presence announcer
+            forkAccountWatcher ssvar
+                               (TCP.tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
+                               acnt
+                               tox
+                               presence
+                               announcer
             return ()
 
     , deactivateAccount      = \k pubname -> do
@@ -256,6 +263,7 @@ data ToxToXMPP = ToxToXMPP
     , txPresence       :: PresenceState Pending
     , txTox            :: Tox JabberClients
     , txSessions       :: TVar (Map.Map Uniq24 AggregateSession)
+    , txTCP            :: TCP.RelayClient
     }
 
 default_nospam :: Word32
@@ -267,6 +275,26 @@ nodeinfoStaleTime = 600 -- consider DHT node address stale after 10 minutes
 nodeinfoSearchInterval :: POSIXTime
 nodeinfoSearchInterval = 15 -- when no address, search DHT node every 15 seconds
 
+connectViaRelay :: ToxToXMPP -> PublicKey -> Tox.DHTPublicKey
+                   -> Announcer -> AnnounceKey -> POSIXTime -> STM (IO ())
+connectViaRelay tx theirKey theirDhtKey ann tkey now = do
+    mcontact <- getContact theirKey (txAccount tx)
+    case mcontact of
+        Nothing -> return $ return ()
+        Just contact -> do
+            established <- activeSesh tx theirKey
+            return $ when (not established) go
+ where
+    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
+
 gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
 gotDhtPubkey theirDhtKey tx theirKey = do
   contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr)
@@ -284,10 +312,11 @@ gotDhtPubkey theirDhtKey tx theirKey = do
     me = key2id myPublicKey
 
     doSearch = do
-      -- TODO: attempt to connect via TCP relays.
       let akey = akeyConnect (txAnnouncer tx) me theirKey
+          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
 
     target :: NodeId
     target = key2id $ dhtpk theirDhtKey
@@ -339,15 +368,14 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
 
     blee = do
       scheduleImmediately (txAnnouncer tx) akey $
-        ScheduledItem $ getCookie tx theirKey theirDhtKey ni (activeSesh addr) (getContact theirKey (txAccount tx))
-
-    tox :: Tox JabberClients
-    tox = txTox tx
-
-    crypto = toxCryptoKeys tox
-
-    activeSesh :: SockAddr -> STM Bool
-    activeSesh a = do
+        ScheduledItem $
+            getCookie tx theirKey theirDhtKey ni
+                      (activeSesh tx theirKey)
+                      (getContact theirKey $ txAccount tx)
+
+activeSesh :: ToxToXMPP -> PublicKey -> STM Bool
+activeSesh tx theirKey = do
+        let myPublicKey = toPublic $ userSecret (txAccount tx)
         ss <- readTVar (txSessions tx)
         u <- xor24 <$> unsafeIOToSTM (hash24 myPublicKey)
                    <*> unsafeIOToSTM (hash24 theirKey)
@@ -364,9 +392,6 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
                         Just False -> return False
                         _          -> (== Established) <$> aggregateStatus c
 
-    client :: Network.Tox.DHT.Handlers.Client
-    client = toxDHT tox
-
 getCookie
       :: ToxToXMPP
       -> PublicKey
@@ -503,6 +528,10 @@ akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey
 akeyConnect announcer me them =
     packAnnounceKey announcer $ "connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them)
 
+akeyConnectTCP :: Announcer -> NodeId -> PublicKey -> AnnounceKey
+akeyConnectTCP announcer me them =
+    packAnnounceKey announcer $ "tcp-connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them)
+
 
 
 -- | Because Tox does not have a friend-request response, we consider an
@@ -645,8 +674,9 @@ closeSessions me them ssvar = do
         closeAll ag
 
 forkAccountWatcher :: TVar (Map.Map Uniq24 AggregateSession)
+                      -> TCP.RelayClient
                       -> Account JabberClients -> Tox JabberClients -> PresenceState Pending -> Announcer -> IO ThreadId
-forkAccountWatcher ssvar acc tox st announcer = forkIO $ do
+forkAccountWatcher ssvar tcp acc tox st announcer = forkIO $ do
     myThreadId >>= flip labelThread ("online:"
                                       ++ show (key2id $ toPublic $ userSecret acc))
     (chan,cs) <- atomically $ do
@@ -658,6 +688,7 @@ forkAccountWatcher ssvar acc tox st announcer = forkIO $ do
                        , txPresence       = st
                        , txTox            = tox
                        , txSessions       = ssvar
+                       , txTCP            = tcp
                        }
     forM_ (HashMap.toList cs) $ \(them,c) -> do
         startConnecting0 tx (id2key them) c "enabled account"
@@ -690,17 +721,17 @@ getStatus me them a c hs = do
     policy <- fromMaybe RefusingToConnect <$> maybe (return Nothing) (readTVar . contactPolicy) c
     mdht <- maybe (return Nothing) (readTVar . contactKeyPacket) c
     maddr <- maybe (return Nothing) (readTVar . contactLastSeenAddr) c
-    haveCookie <- haveCachedCookie hs me them
-    return $ statusLogic astat policy mdht maddr haveCookie
+    cookieIsPending <- getPendingCookieFlag hs me them
+    return $ statusLogic astat policy mdht maddr cookieIsPending
 
 statusLogic :: Status ToxProgress -> Policy -> Maybe dhtkey -> Maybe addr -> Bool -> Status ToxProgress
-statusLogic astat policy mdht maddr haveCookie = case () of
+statusLogic astat policy mdht maddr cookieIsPending = case () of
     ()  | Established                      <- astat  -> Established
         | InProgress AwaitingSessionPacket <- astat  -> InProgress AwaitingSessionPacket
         | RefusingToConnect                <- policy -> Dormant
         | Nothing                          <- mdht   -> InProgress AwaitingDHTKey
         | Nothing                          <- maddr  -> InProgress AcquiringIPAddress
-        | not haveCookie                             -> InProgress AcquiringCookie
+        | cookieIsPending                            -> InProgress AcquiringCookie
         | otherwise                                  -> InProgress AwaitingHandshake