diff options
-rw-r--r-- | Connection/Tox.hs | 36 | ||||
-rw-r--r-- | src/Network/Tox/Crypto/Handlers.hs | 2 | ||||
-rw-r--r-- | src/Network/Tox/DHT/Handlers.hs | 22 |
3 files changed, 53 insertions, 7 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 | |||
13 | import Data.Functor.Identity | 13 | import Data.Functor.Identity |
14 | import qualified Data.Map as Map | 14 | import qualified Data.Map as Map |
15 | import Connection.Tox.Threads | 15 | import Connection.Tox.Threads |
16 | import Network.Tox | ||
16 | import Network.Tox.NodeId | 17 | import Network.Tox.NodeId |
18 | import Network.Tox.DHT.Handlers | ||
17 | import PingMachine | 19 | import PingMachine |
18 | import Text.Read | 20 | import Text.Read |
19 | #ifdef THREAD_DEBUG | 21 | #ifdef THREAD_DEBUG |
@@ -29,10 +31,10 @@ import GHC.Conc (threadStatus,ThreadStatus(..)) | |||
29 | 31 | ||
30 | data Parameters = Parameters | 32 | data 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 | ||
38 | data Key = Key NodeId{-me-} NodeId{-them-} | 40 | data 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 | ||
119 | callbackId :: Int | ||
120 | callbackId = 1 | ||
121 | |||
117 | -- | This function will fork threads as necessary. | 122 | -- | This function will fork threads as necessary. |
118 | setToxPolicy :: Parameters | 123 | setToxPolicy :: 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 | ||
172 | showKey_ :: Key -> String | 196 | showKey_ :: Key -> String |
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index 2fc12559..20560a48 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs | |||
@@ -56,7 +56,7 @@ import Debug.Trace | |||
56 | import Text.Printf | 56 | import Text.Printf |
57 | import Data.Bool | 57 | import Data.Bool |
58 | import Connection (Status(..)) | 58 | import Connection (Status(..)) |
59 | import Connection.Tox (ToxProgress(..)) | 59 | import Connection.Tox.Threads (ToxProgress(..)) |
60 | 60 | ||
61 | 61 | ||
62 | -- * These types are isomorphic to Maybe, but have the advantage of documenting | 62 | -- * These types are isomorphic to Maybe, but have the advantage of documenting |
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs index 25244a9b..091374f5 100644 --- a/src/Network/Tox/DHT/Handlers.hs +++ b/src/Network/Tox/DHT/Handlers.hs | |||
@@ -130,6 +130,28 @@ data Routing = Routing | |||
130 | , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback]) | 130 | , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback]) |
131 | } | 131 | } |
132 | 132 | ||
133 | registerNodeCallback :: Routing -> NodeInfoCallback -> STM () | ||
134 | registerNodeCallback Routing{nodesOfInterest} cb = do | ||
135 | cbm <- readTVar nodesOfInterest | ||
136 | let ns = fromMaybe [] $ HashMap.lookup (interestingNodeId cb) cbm | ||
137 | bs = filter nonMatching ns | ||
138 | where nonMatching n = (listenerId n /= listenerId cb) | ||
139 | writeTVar nodesOfInterest $ HashMap.insert (interestingNodeId cb) | ||
140 | (cb : bs) | ||
141 | cbm | ||
142 | |||
143 | unregisterNodeCallback :: Int -> Routing -> NodeId -> STM () | ||
144 | unregisterNodeCallback callbackId Routing{nodesOfInterest} nid = do | ||
145 | cbm <- readTVar nodesOfInterest | ||
146 | let ns = fromMaybe [] $ HashMap.lookup nid cbm | ||
147 | bs = filter nonMatching ns | ||
148 | where nonMatching n = (listenerId n /= callbackId) | ||
149 | writeTVar nodesOfInterest | ||
150 | $ if null bs | ||
151 | then HashMap.delete nid cbm | ||
152 | else HashMap.insert nid bs cbm | ||
153 | |||
154 | |||
133 | sched4 :: Routing -> TVar (Int.PSQ POSIXTime) | 155 | sched4 :: Routing -> TVar (Int.PSQ POSIXTime) |
134 | sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue | 156 | sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue |
135 | 157 | ||