From 4728116433ddd449dc4c654847ed2f35a38605db Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Wed, 30 May 2018 21:11:47 -0400
Subject: WIP: Deliver friend-request to xmpp client. (continued)

---
 ToxToXMPP.hs     | 36 ++++++++++++++++++++++++------------
 examples/dhtd.hs |  9 ++++-----
 todo.txt         |  2 ++
 3 files changed, 30 insertions(+), 17 deletions(-)

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 12a08901..26cfa58c 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -7,6 +7,7 @@ import Data.XML.Types               as XML
 import Network.Tox.Crypto.Transport as Tox
 
 import Announcer
+import ClientState
 import Connection
 import Connection.Tox                as Connection
 import Control.Concurrent.STM
@@ -16,6 +17,8 @@ import Crypto.Tox
 import Data.Bits
 import Data.Function
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Map            as Map
+import qualified Data.Set            as Set
 import qualified Data.Set            as Set
 import qualified Data.Text           as T
          ;import Data.Text           (Text)
@@ -51,18 +54,27 @@ key2jid nospam key = T.pack $ show $ NoSpamId nsp key
     nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
     nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
 
-dispatch :: Account -> Conn -> ContactEvent -> IO ()
-dispatch acnt conn (PolicyChange theirkey policy                  ) = return () -- todo
-dispatch acnt conn (OnionRouted  theirkey (OnionDHTPublicKey pkey)) = return () -- todo
-dispatch acnt conn (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
-    let self = accountJID acnt
-        theirjid = key2jid (friendNoSpam fr) theirkey
-    ask <- presenceSolicitation theirjid self
-    sendModifiedStanzaToClient ask (connChan conn)
+dispatch :: Account -> PresenceState -> ContactEvent -> IO ()
+dispatch acnt st (PolicyChange theirkey policy                  ) = return () -- todo
+dispatch acnt st (OnionRouted  theirkey (OnionDHTPublicKey pkey)) = return () -- todo
+dispatch acnt st (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
+    k2c <- atomically $ do
+        refs <- readTVar (clientRefs acnt)
+        k2c <- Map.filterWithKey (\k _ -> k `Set.member` refs) <$> readTVar (keyToChan st)
+        clients <- readTVar (clients st)
+        return $ Map.intersectionWith (,) k2c clients
+    let theirjid = key2jid (friendNoSpam fr) theirkey
+    forM_ k2c $ \(conn,client) -> do
+        self <- localJID (clientUser client) (clientProfile client) (clientResource client)
+        ask <- presenceSolicitation theirjid self
+        -- TODO Send friend-request text as an instant message or at least
+        -- embed it in the stanza as a <status> element.
+        sendModifiedStanzaToClient ask (connChan conn)
 
-forkAccountWatcher :: Account -> Tox -> Conn -> IO ThreadId
-forkAccountWatcher acc tox conn = forkIO $ do
-    myThreadId >>= flip labelThread "tox-account"
+forkAccountWatcher :: Account -> Tox -> PresenceState -> IO ThreadId
+forkAccountWatcher acc tox st = forkIO $ do
+    myThreadId >>= flip labelThread ("tox-xmpp:"
+                                      ++ show (key2id $ toPublic $ userSecret acc))
     (chan,contacts) <- atomically $ do
                 chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading.
                 contacts <- readTVar (contacts acc)
@@ -77,5 +89,5 @@ forkAccountWatcher acc tox conn = forkIO $ do
                 refs <- readTVar $ clientRefs acc
                 check $ Set.null refs
                 return Nothing
-    forM_ mev $ \ev -> dispatch acc conn ev >> loop
+    forM_ mev $ \ev -> dispatch acc st ev >> loop
 
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 4f26fc16..b6680f2e 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1412,17 +1412,16 @@ toxman announcer toxbkts tox presence = ToxManager
         let ContactInfo{ accounts } = Tox.toxContactInfo tox
             pub = toPublic seckey
             pubid = Tox.key2id pub
-        (mcon,newlyActive) <- atomically $ do
+        (acnt,newlyActive) <- atomically $ do
             macnt <- HashMap.lookup pubid <$> readTVar accounts
             acnt <- maybe (newAccount seckey) return macnt
             rs <- readTVar $ clientRefs acnt
             writeTVar (clientRefs acnt) $! Set.insert k rs
             modifyTVar accounts (HashMap.insert pubid acnt)
-            mcon <- fmap ((,) acnt) . Map.lookup k <$> readTVar (keyToChan presence)
             if not (Set.null rs)
-                then return (mcon,[])
+                then return (acnt,[])
                 else do
-                    fmap ((,) mcon) $ forM toxbkts $ \(nm,bkts) -> do
+                    fmap ((,) acnt) $ forM toxbkts $ \(nm,bkts) -> do
                         akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
                         return (akey,bkts)
         forM_ newlyActive $ \(akey,bkts) -> do
@@ -1437,7 +1436,7 @@ toxman announcer toxbkts tox presence = ToxManager
                                      toxAnnounceInterval)
                      pub
 
-            forM_ mcon $ \(acnt,conn) -> forkAccountWatcher acnt tox conn
+            forkAccountWatcher acnt tox presence
             return ()
     , deactivateAccount      = \k pubname -> do
        bStopped <- fmap (fromMaybe False) $ atomically $ do
diff --git a/todo.txt b/todo.txt
index 7ea0dd8e..54019a21 100644
--- a/todo.txt
+++ b/todo.txt
@@ -1,3 +1,5 @@
+bug: more trampolines than routing table nodes? (possibly NAT-related)
+
 ui: better error message for a +dhtkey without any selected key.
 
 tox: tcp relay
-- 
cgit v1.2.3