1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module ToxManager where
import Announcer
import Connection
-- import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Crypto.Tox
import Data.HashMap.Strict as HashMap
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time.Clock.POSIX
import Network.Address
import Network.Kademlia.Routing as R
import Network.Kademlia.Search
import qualified Network.Tox as Tox
import Network.Tox.ContactInfo as Tox
import qualified Network.Tox.Crypto.Handlers as Tox
-- import qualified Network.Tox.DHT.Handlers as Tox
import qualified Network.Tox.DHT.Transport as Tox
import qualified Network.Tox.Onion.Handlers as Tox
import qualified Network.Tox.Onion.Transport as Tox
import Presence
import System.IO
import Text.Read
import ToxToXMPP
import XMPPServer (ConnectionKey)
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc (labelThread)
#endif
toxAnnounceInterval :: POSIXTime
toxAnnounceInterval = 15
toxAnnounceSendData :: Tox.Tox -> PublicKey
-> Nonce32
-> Maybe Tox.NodeInfo
-> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse))
toxAnnounceSendData tox pubkey token = \case
Just ni -> Tox.putRendezvous (Tox.onionTimeout tox)
(Tox.toxCryptoKeys tox)
(Tox.toxOnion tox)
(pubkey :: PublicKey)
(token :: Nonce32)
ni
Nothing -> return Nothing
toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous
toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox)
-- |
--
-- These hooks will be invoked in order to connect to *.tox hosts in a user's
-- XMPP roster.
toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> PresenceState -> ToxManager ConnectionKey
toxman announcer toxbkts tox presence = ToxManager
{ activateAccount = \k pubname seckey -> do
hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
let ContactInfo{ accounts } = Tox.toxContactInfo tox
pub = toPublic seckey
pubid = Tox.key2id pub
(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)
if not (Set.null rs)
then return (acnt,[])
else do
fmap ((,) acnt) $ forM toxbkts $ \(nm,bkts) -> do
akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
return (akey,bkts)
forM_ newlyActive $ \(akey,bkts) -> do
-- Schedule recurring announce.
--
schedule announcer
akey
(AnnounceMethod (toxQSearch tox)
(Right $ toxAnnounceSendData tox)
bkts
pubid
toxAnnounceInterval)
pub
forkAccountWatcher acnt tox presence
return ()
, deactivateAccount = \k pubname -> do
hPutStrLn stderr $ "toxman DECTIVATE (todo) 1 " ++ show pubname
let ContactInfo{ accounts } = Tox.toxContactInfo tox
mpubid = readMaybe $ T.unpack $ T.take 43 pubname
bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
forM mpubid $ \pubid -> do
refs <- do
macnt <- HashMap.lookup pubid <$> readTVar accounts
rs <- fromMaybe Set.empty <$> mapM (readTVar . clientRefs) macnt
forM_ macnt $ \acnt -> do
modifyTVar' (clientRefs acnt) $ Set.delete k
return rs
if (Set.null $ refs Set.\\ Set.singleton k) then do
-- TODO
-- If this is the last reference to a non-connected contact:
-- Stop the recurring search for that contact
--
-- Stop recurring announce.
fmap Just $ forM toxbkts $ \(nm,bkts) -> do
akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
return (akey,bkts)
else return Nothing
forM_ bStopped $ \kbkts -> do
hPutStrLn stderr $ "toxman DECTIVATE (todo) 3 " ++ show pubname
let Just pubid = mpubid
pub = Tox.id2key pubid
forM_ kbkts $ \(akey,bkts) -> do
cancel announcer
akey
(AnnounceMethod (toxQSearch tox)
(Right $ toxAnnounceSendData tox)
bkts
pubid
toxAnnounceInterval)
pub
, setToxConnectionPolicy = \me them p -> do
let m = do meid <- readMaybe $ T.unpack $ T.take 43 me
themid <- readMaybe $ T.unpack $ T.take 43 them
return $ Tox.Key meid themid
hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p,fmap (const ()) m)
forM_ m $ \k -> do
setPolicy (Tox.toxMgr tox) k p
case p of
TryingToConnect -> do
let db@ContactInfo{ accounts } = Tox.toxContactInfo tox
sequence_ $ do
let Tox.Key meid themid = k
Just $ atomically $ do
accs <- readTVar accounts
case HashMap.lookup meid accs of
Nothing -> return () -- Unknown account.
Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc
-- If unscheduled and unconnected, schedule recurring search for this contact.
_ -> return () -- Remove contact.
}
|
