summaryrefslogtreecommitdiff
path: root/Connection/Tox.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2018-06-13 20:50:00 -0400
committerjoe <joe@jerkface.net>2018-06-13 20:50:00 -0400
commitd8ac778e803ac6de7c01ab4c8af767647ebc2d07 (patch)
tree98b4ff2acb4533c078ff0ced369a7cac69bc089c /Connection/Tox.hs
parent2ad144b323122c5eecfc9156a6d65a7018f003ad (diff)
tox: mechanism to register node-info callbacks.
Diffstat (limited to 'Connection/Tox.hs')
-rw-r--r--Connection/Tox.hs36
1 files changed, 30 insertions, 6 deletions
diff --git a/Connection/Tox.hs b/Connection/Tox.hs
index 41361d8f..de2bb879 100644
--- a/Connection/Tox.hs
+++ b/Connection/Tox.hs
@@ -13,7 +13,9 @@ import Data.Dependent.Sum
13import Data.Functor.Identity 13import Data.Functor.Identity
14import qualified Data.Map as Map 14import qualified Data.Map as Map
15import Connection.Tox.Threads 15import Connection.Tox.Threads
16import Network.Tox
16import Network.Tox.NodeId 17import Network.Tox.NodeId
18import Network.Tox.DHT.Handlers
17import PingMachine 19import PingMachine
18import Text.Read 20import Text.Read
19#ifdef THREAD_DEBUG 21#ifdef THREAD_DEBUG
@@ -29,10 +31,10 @@ import GHC.Conc (threadStatus,ThreadStatus(..))
29 31
30data Parameters = Parameters 32data Parameters = Parameters
31 { -- | Various Tox transports and clients. 33 { -- | Various Tox transports and clients.
32 -- toxTransports :: Tox 34 toxTransports :: Tox
33 -- | Thread to be forked when a connection is established. 35 -- | Thread to be forked when a connection is established.
34 -- TODO: this function should accept relevant parameters. 36 -- TODO: this function should accept relevant parameters.
35 onToxSession :: IO () 37 , onToxSession :: IO ()
36 } 38 }
37 39
38data Key = Key NodeId{-me-} NodeId{-them-} 40data Key = Key NodeId{-me-} NodeId{-them-}
@@ -114,6 +116,9 @@ lookupForPolicyChange conmap k policy = atomically $ do
114 guard $ p /= policy 116 guard $ p /= policy
115 return st 117 return st
116 118
119callbackId :: Int
120callbackId = 1
121
117-- | This function will fork threads as necessary. 122-- | This function will fork threads as necessary.
118setToxPolicy :: Parameters 123setToxPolicy :: Parameters
119 -> TVar (Map.Map Key SessionState) 124 -> TVar (Map.Map Key SessionState)
@@ -140,10 +145,17 @@ setToxPolicy params conmap k policy = case policy of
140 refreshing <- launch ("refresh:"++show k) 145 refreshing <- launch ("refresh:"++show k)
141 (G.InProgress $ toEnum 0) 146 (G.InProgress $ toEnum 0)
142 $ freshenContact getPolicy _get_status _freshen_methods 147 $ freshenContact getPolicy _get_status _freshen_methods
143 atomically $ writeTVar (sessionTasks st) 148 atomically $ do
144 $ SessionTasks accepting persuing refreshing 149 writeTVar (sessionTasks st) $ SessionTasks accepting persuing refreshing
150 let routing = toxRouting $ toxTransports params
151 Key _ nid = k
152 registerNodeCallback routing $ NodeInfoCallback
153 { interestingNodeId = nid
154 , listenerId = callbackId
155 , observedAddress = \ni -> return () -- TODO
156 , rumoredAddress = \saddr ni -> return () -- TODO
157 }
145 return () 158 return ()
146 return ()
147 RefusingToConnect -> do -- disconnect or cancel any pending connection 159 RefusingToConnect -> do -- disconnect or cancel any pending connection
148 mst <- lookupForPolicyChange conmap k policy 160 mst <- lookupForPolicyChange conmap k policy
149 -- Since the 3 connection threads poll the current policy, they should 161 -- Since the 3 connection threads poll the current policy, they should
@@ -152,6 +164,10 @@ setToxPolicy params conmap k policy = case policy of
152 -- Here we block until they finish. 164 -- Here we block until they finish.
153 forM_ mst $ \st -> do 165 forM_ mst $ \st -> do
154 atomically $ do 166 atomically $ do
167 let routing = toxRouting $ toxTransports params
168 Key _ nid = k
169 unregisterNodeCallback callbackId routing nid
170 atomically $ do
155 tasks <- readTVar (sessionTasks st) 171 tasks <- readTVar (sessionTasks st)
156 a <- readTVar $ taskState (accepting tasks) 172 a <- readTVar $ taskState (accepting tasks)
157 p <- readTVar $ taskState (persuing tasks) 173 p <- readTVar $ taskState (persuing tasks)
@@ -166,7 +182,15 @@ setToxPolicy params conmap k policy = case policy of
166 accept_thread <- launch ("accept:"++show k) 182 accept_thread <- launch ("accept:"++show k)
167 (G.InProgress $ toEnum 0) 183 (G.InProgress $ toEnum 0)
168 $ acceptContact getPolicy _accept_methods 184 $ acceptContact getPolicy _accept_methods
169 return () 185 atomically $ do
186 let routing = toxRouting $ toxTransports params
187 Key _ nid = k
188 registerNodeCallback routing $ NodeInfoCallback
189 { interestingNodeId = nid
190 , listenerId = callbackId
191 , observedAddress = \ni -> return () -- TODO
192 , rumoredAddress = \saddr ni -> return () -- TODO
193 }
170 194
171 195
172showKey_ :: Key -> String 196showKey_ :: Key -> String