diff options
author | joe <joe@jerkface.net> | 2018-05-30 21:11:47 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2018-05-30 21:11:47 -0400 |
commit | 4728116433ddd449dc4c654847ed2f35a38605db (patch) | |
tree | 747274dd8c0f3eec7d32f0ebdcfb8493bc5013b8 | |
parent | 1a958b20ebc9ee24dc5ac5dfe505ff7f8f3434e6 (diff) |
WIP: Deliver friend-request to xmpp client. (continued)
-rw-r--r-- | ToxToXMPP.hs | 36 | ||||
-rw-r--r-- | examples/dhtd.hs | 9 | ||||
-rw-r--r-- | 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 | |||
7 | import Network.Tox.Crypto.Transport as Tox | 7 | import Network.Tox.Crypto.Transport as Tox |
8 | 8 | ||
9 | import Announcer | 9 | import Announcer |
10 | import ClientState | ||
10 | import Connection | 11 | import Connection |
11 | import Connection.Tox as Connection | 12 | import Connection.Tox as Connection |
12 | import Control.Concurrent.STM | 13 | import Control.Concurrent.STM |
@@ -16,6 +17,8 @@ import Crypto.Tox | |||
16 | import Data.Bits | 17 | import Data.Bits |
17 | import Data.Function | 18 | import Data.Function |
18 | import qualified Data.HashMap.Strict as HashMap | 19 | import qualified Data.HashMap.Strict as HashMap |
20 | import qualified Data.Map as Map | ||
21 | import qualified Data.Set as Set | ||
19 | import qualified Data.Set as Set | 22 | import qualified Data.Set as Set |
20 | import qualified Data.Text as T | 23 | import qualified Data.Text as T |
21 | ;import Data.Text (Text) | 24 | ;import Data.Text (Text) |
@@ -51,18 +54,27 @@ key2jid nospam key = T.pack $ show $ NoSpamId nsp key | |||
51 | nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 | 54 | nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 |
52 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 | 55 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 |
53 | 56 | ||
54 | dispatch :: Account -> Conn -> ContactEvent -> IO () | 57 | dispatch :: Account -> PresenceState -> ContactEvent -> IO () |
55 | dispatch acnt conn (PolicyChange theirkey policy ) = return () -- todo | 58 | dispatch acnt st (PolicyChange theirkey policy ) = return () -- todo |
56 | dispatch acnt conn (OnionRouted theirkey (OnionDHTPublicKey pkey)) = return () -- todo | 59 | dispatch acnt st (OnionRouted theirkey (OnionDHTPublicKey pkey)) = return () -- todo |
57 | dispatch acnt conn (OnionRouted theirkey (OnionFriendRequest fr) ) = do | 60 | dispatch acnt st (OnionRouted theirkey (OnionFriendRequest fr) ) = do |
58 | let self = accountJID acnt | 61 | k2c <- atomically $ do |
59 | theirjid = key2jid (friendNoSpam fr) theirkey | 62 | refs <- readTVar (clientRefs acnt) |
60 | ask <- presenceSolicitation theirjid self | 63 | k2c <- Map.filterWithKey (\k _ -> k `Set.member` refs) <$> readTVar (keyToChan st) |
61 | sendModifiedStanzaToClient ask (connChan conn) | 64 | clients <- readTVar (clients st) |
65 | return $ Map.intersectionWith (,) k2c clients | ||
66 | let theirjid = key2jid (friendNoSpam fr) theirkey | ||
67 | forM_ k2c $ \(conn,client) -> do | ||
68 | self <- localJID (clientUser client) (clientProfile client) (clientResource client) | ||
69 | ask <- presenceSolicitation theirjid self | ||
70 | -- TODO Send friend-request text as an instant message or at least | ||
71 | -- embed it in the stanza as a <status> element. | ||
72 | sendModifiedStanzaToClient ask (connChan conn) | ||
62 | 73 | ||
63 | forkAccountWatcher :: Account -> Tox -> Conn -> IO ThreadId | 74 | forkAccountWatcher :: Account -> Tox -> PresenceState -> IO ThreadId |
64 | forkAccountWatcher acc tox conn = forkIO $ do | 75 | forkAccountWatcher acc tox st = forkIO $ do |
65 | myThreadId >>= flip labelThread "tox-account" | 76 | myThreadId >>= flip labelThread ("tox-xmpp:" |
77 | ++ show (key2id $ toPublic $ userSecret acc)) | ||
66 | (chan,contacts) <- atomically $ do | 78 | (chan,contacts) <- atomically $ do |
67 | chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading. | 79 | chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading. |
68 | contacts <- readTVar (contacts acc) | 80 | contacts <- readTVar (contacts acc) |
@@ -77,5 +89,5 @@ forkAccountWatcher acc tox conn = forkIO $ do | |||
77 | refs <- readTVar $ clientRefs acc | 89 | refs <- readTVar $ clientRefs acc |
78 | check $ Set.null refs | 90 | check $ Set.null refs |
79 | return Nothing | 91 | return Nothing |
80 | forM_ mev $ \ev -> dispatch acc conn ev >> loop | 92 | forM_ mev $ \ev -> dispatch acc st ev >> loop |
81 | 93 | ||
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 | |||
1412 | let ContactInfo{ accounts } = Tox.toxContactInfo tox | 1412 | let ContactInfo{ accounts } = Tox.toxContactInfo tox |
1413 | pub = toPublic seckey | 1413 | pub = toPublic seckey |
1414 | pubid = Tox.key2id pub | 1414 | pubid = Tox.key2id pub |
1415 | (mcon,newlyActive) <- atomically $ do | 1415 | (acnt,newlyActive) <- atomically $ do |
1416 | macnt <- HashMap.lookup pubid <$> readTVar accounts | 1416 | macnt <- HashMap.lookup pubid <$> readTVar accounts |
1417 | acnt <- maybe (newAccount seckey) return macnt | 1417 | acnt <- maybe (newAccount seckey) return macnt |
1418 | rs <- readTVar $ clientRefs acnt | 1418 | rs <- readTVar $ clientRefs acnt |
1419 | writeTVar (clientRefs acnt) $! Set.insert k rs | 1419 | writeTVar (clientRefs acnt) $! Set.insert k rs |
1420 | modifyTVar accounts (HashMap.insert pubid acnt) | 1420 | modifyTVar accounts (HashMap.insert pubid acnt) |
1421 | mcon <- fmap ((,) acnt) . Map.lookup k <$> readTVar (keyToChan presence) | ||
1422 | if not (Set.null rs) | 1421 | if not (Set.null rs) |
1423 | then return (mcon,[]) | 1422 | then return (acnt,[]) |
1424 | else do | 1423 | else do |
1425 | fmap ((,) mcon) $ forM toxbkts $ \(nm,bkts) -> do | 1424 | fmap ((,) acnt) $ forM toxbkts $ \(nm,bkts) -> do |
1426 | akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid) | 1425 | akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid) |
1427 | return (akey,bkts) | 1426 | return (akey,bkts) |
1428 | forM_ newlyActive $ \(akey,bkts) -> do | 1427 | forM_ newlyActive $ \(akey,bkts) -> do |
@@ -1437,7 +1436,7 @@ toxman announcer toxbkts tox presence = ToxManager | |||
1437 | toxAnnounceInterval) | 1436 | toxAnnounceInterval) |
1438 | pub | 1437 | pub |
1439 | 1438 | ||
1440 | forM_ mcon $ \(acnt,conn) -> forkAccountWatcher acnt tox conn | 1439 | forkAccountWatcher acnt tox presence |
1441 | return () | 1440 | return () |
1442 | , deactivateAccount = \k pubname -> do | 1441 | , deactivateAccount = \k pubname -> do |
1443 | bStopped <- fmap (fromMaybe False) $ atomically $ do | 1442 | bStopped <- fmap (fromMaybe False) $ atomically $ do |
@@ -1,3 +1,5 @@ | |||
1 | bug: more trampolines than routing table nodes? (possibly NAT-related) | ||
2 | |||
1 | ui: better error message for a +dhtkey without any selected key. | 3 | ui: better error message for a +dhtkey without any selected key. |
2 | 4 | ||
3 | tox: tcp relay | 5 | tox: tcp relay |