diff options
-rw-r--r-- | Announcer.hs | 8 | ||||
-rw-r--r-- | Connection/Tox.hs | 8 | ||||
-rw-r--r-- | Connection/Tox/Threads.hs | 6 | ||||
-rw-r--r-- | ToxManager.hs | 4 | ||||
-rw-r--r-- | ToxToXMPP.hs | 128 | ||||
-rw-r--r-- | examples/dhtd.hs | 8 | ||||
-rw-r--r-- | src/Network/Tox.hs | 6 | ||||
-rw-r--r-- | src/Network/Tox/ContactInfo.hs | 19 |
8 files changed, 108 insertions, 79 deletions
diff --git a/Announcer.hs b/Announcer.hs index 41c1c2a6..89dc5c3b 100644 --- a/Announcer.hs +++ b/Announcer.hs | |||
@@ -46,11 +46,11 @@ newtype AnnounceKey = AnnounceKey ByteString | |||
46 | instance Show AnnounceKey where | 46 | instance Show AnnounceKey where |
47 | show (AnnounceKey bs) = "AnnounceKey " ++ show (Char8.unpack bs) | 47 | show (AnnounceKey bs) = "AnnounceKey " ++ show (Char8.unpack bs) |
48 | 48 | ||
49 | packAnnounceKey :: Announcer -> String -> STM AnnounceKey | 49 | packAnnounceKey :: Announcer -> String -> AnnounceKey |
50 | packAnnounceKey _ = return . AnnounceKey . Char8.pack | 50 | packAnnounceKey _ = AnnounceKey . Char8.pack |
51 | 51 | ||
52 | unpackAnnounceKey :: Announcer -> AnnounceKey -> STM String | 52 | unpackAnnounceKey :: Announcer -> AnnounceKey -> String |
53 | unpackAnnounceKey _ (AnnounceKey bs) = return $ Char8.unpack bs | 53 | unpackAnnounceKey _ (AnnounceKey bs) = Char8.unpack bs |
54 | 54 | ||
55 | -- | Actions that can be scheduled to occur at some particular time in the | 55 | -- | Actions that can be scheduled to occur at some particular time in the |
56 | -- future. Since periodic event handlers are responsible for re-scheduling | 56 | -- future. Since periodic event handlers are responsible for re-scheduling |
diff --git a/Connection/Tox.hs b/Connection/Tox.hs index 3f5f7e2c..9612f1e5 100644 --- a/Connection/Tox.hs +++ b/Connection/Tox.hs | |||
@@ -193,12 +193,12 @@ setToxPolicy params conmap k@(Key me them) policy = do | |||
193 | registerNodeCallback routing $ NodeInfoCallback | 193 | registerNodeCallback routing $ NodeInfoCallback |
194 | { interestingNodeId = nid | 194 | { interestingNodeId = nid |
195 | , listenerId = callbackId | 195 | , listenerId = callbackId |
196 | , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) | 196 | , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) |
197 | , rumoredAddress = \now saddr ni -> do | 197 | , rumoredAddress = \now saddr ni -> do |
198 | m <- readTVar (contactLastSeenAddr c) | 198 | m <- readTVar (contactLastSeenAddr c) |
199 | -- TODO remember information source and handle multiple rumors. | 199 | -- TODO remember information source and handle multiple rumors. |
200 | case m of Just _ -> return () | 200 | case m of Just _ -> return () |
201 | Nothing -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) | 201 | Nothing -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) |
202 | } | 202 | } |
203 | return () | 203 | return () |
204 | RefusingToConnect -> do -- disconnect or cancel any pending connection | 204 | RefusingToConnect -> do -- disconnect or cancel any pending connection |
@@ -235,12 +235,12 @@ setToxPolicy params conmap k@(Key me them) policy = do | |||
235 | registerNodeCallback routing $ NodeInfoCallback | 235 | registerNodeCallback routing $ NodeInfoCallback |
236 | { interestingNodeId = nid | 236 | { interestingNodeId = nid |
237 | , listenerId = callbackId | 237 | , listenerId = callbackId |
238 | , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) | 238 | , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) |
239 | , rumoredAddress = \now saddr ni -> do | 239 | , rumoredAddress = \now saddr ni -> do |
240 | m <- readTVar (contactLastSeenAddr c) | 240 | m <- readTVar (contactLastSeenAddr c) |
241 | -- TODO remember information source and handle multiple rumors. | 241 | -- TODO remember information source and handle multiple rumors. |
242 | case m of Just _ -> return () | 242 | case m of Just _ -> return () |
243 | Nothing -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) | 243 | Nothing -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) |
244 | } | 244 | } |
245 | 245 | ||
246 | stringToKey_ :: String -> Maybe Key | 246 | stringToKey_ :: String -> Maybe Key |
diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs index ba49b7dc..de719655 100644 --- a/Connection/Tox/Threads.hs +++ b/Connection/Tox/Threads.hs | |||
@@ -140,7 +140,7 @@ pursueContact getPolicy getStatus PursueContactMethods{..} statusVar = do | |||
140 | (do | 140 | (do |
141 | (stamp_theirDhtKey,theirDhtKey) <- second DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact) | 141 | (stamp_theirDhtKey,theirDhtKey) <- second DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact) |
142 | (stamp_saddr,saddr) <- retryUntilJust (contactLastSeenAddr contact) | 142 | (stamp_saddr,saddr) <- retryUntilJust (contactLastSeenAddr contact) |
143 | ni <- either (const retry) return $ nodeInfo (key2id theirDhtKey) saddr | 143 | ni <- either (const retry) return $ nodeInfo (key2id theirDhtKey) (_fixme saddr) |
144 | return $ do | 144 | return $ do |
145 | -- AcquiringCookie | 145 | -- AcquiringCookie |
146 | atomically $ writeTVar statusVar (InProgress AcquiringCookie) | 146 | atomically $ writeTVar statusVar (InProgress AcquiringCookie) |
@@ -166,11 +166,11 @@ pursueContact getPolicy getStatus PursueContactMethods{..} statusVar = do | |||
166 | newsession <- generateSecretKey | 166 | newsession <- generateSecretKey |
167 | timestamp <- getPOSIXTime | 167 | timestamp <- getPOSIXTime |
168 | (myhandshake,ioAction) | 168 | (myhandshake,ioAction) |
169 | <- atomically $ freshCryptoSession allsessions saddr newsession timestamp hp | 169 | <- atomically $ freshCryptoSession allsessions (_fixme saddr) newsession timestamp hp |
170 | ioAction | 170 | ioAction |
171 | -- send handshake | 171 | -- send handshake |
172 | forM myhandshake $ \response_handshake -> do | 172 | forM myhandshake $ \response_handshake -> do |
173 | sendHandshake allsessions saddr response_handshake | 173 | sendHandshake allsessions (_fixme saddr) response_handshake |
174 | atomically $ writeTVar statusVar $ InProgress AwaitingHandshake | 174 | atomically $ writeTVar statusVar $ InProgress AwaitingHandshake |
175 | return shortRetryInterval | 175 | return shortRetryInterval |
176 | -- AwaitingHandshake | 176 | -- AwaitingHandshake |
diff --git a/ToxManager.hs b/ToxManager.hs index bcc4d86d..360f78e8 100644 --- a/ToxManager.hs +++ b/ToxManager.hs | |||
@@ -78,7 +78,7 @@ toxman announcer toxbkts tox presence = ToxManager | |||
78 | forM_ newlyActive $ \nearNodes -> do | 78 | forM_ newlyActive $ \nearNodes -> do |
79 | -- Schedule recurring announce. | 79 | -- Schedule recurring announce. |
80 | -- | 80 | -- |
81 | akey <- atomically $ packAnnounceKey announcer $ "toxid:" ++ show pubid | 81 | let akey = packAnnounceKey announcer $ "toxid:" ++ show pubid |
82 | scheduleAnnounce announcer | 82 | scheduleAnnounce announcer |
83 | akey | 83 | akey |
84 | (AnnounceMethod (toxQSearch tox) | 84 | (AnnounceMethod (toxQSearch tox) |
@@ -109,7 +109,7 @@ toxman announcer toxbkts tox presence = ToxManager | |||
109 | -- Stop the recurring search for that contact | 109 | -- Stop the recurring search for that contact |
110 | -- | 110 | -- |
111 | -- Stop recurring announce. | 111 | -- Stop recurring announce. |
112 | akey <- packAnnounceKey announcer ("toxid:" ++ show pubid) | 112 | let akey = packAnnounceKey announcer ("toxid:" ++ show pubid) |
113 | fmap Just $ forM toxbkts $ \(nm,bkts) -> do | 113 | fmap Just $ forM toxbkts $ \(nm,bkts) -> do |
114 | return (akey,bkts) | 114 | return (akey,bkts) |
115 | else return Nothing | 115 | else return Nothing |
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs index adeb7455..2071ae9e 100644 --- a/ToxToXMPP.hs +++ b/ToxToXMPP.hs | |||
@@ -159,7 +159,7 @@ data Moot v = Moot | |||
159 | data NNS a b c = NNS { -- NetcryptoNegotiationState | 159 | data NNS a b c = NNS { -- NetcryptoNegotiationState |
160 | sessionDesired :: Bool, | 160 | sessionDesired :: Bool, |
161 | theirPublicKey :: a Tox.DHTPublicKey, | 161 | theirPublicKey :: a Tox.DHTPublicKey, |
162 | theirAddress :: b SockAddr, | 162 | theirAddress :: b NodeInfo, |
163 | theirCookie :: c (Tox.Cookie Encrypted), | 163 | theirCookie :: c (Tox.Cookie Encrypted), |
164 | sessionIsActive :: Bool | 164 | sessionIsActive :: Bool |
165 | } | 165 | } |
@@ -172,7 +172,7 @@ data NS | |||
172 | | Stage5 (NNS Acquired Acquired Acquired) | 172 | | Stage5 (NNS Acquired Acquired Acquired) |
173 | 173 | ||
174 | gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () | 174 | gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () |
175 | gotDhtPubkey pubkey tx theirKey = do | 175 | gotDhtPubkey theirDhtKey tx theirKey = do |
176 | contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr) | 176 | contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr) |
177 | forM_ contact $ \lastSeen -> do | 177 | forM_ contact $ \lastSeen -> do |
178 | case lastSeen of | 178 | case lastSeen of |
@@ -188,33 +188,13 @@ gotDhtPubkey pubkey tx theirKey = do | |||
188 | me = key2id myPublicKey | 188 | me = key2id myPublicKey |
189 | 189 | ||
190 | doSearch = do | 190 | doSearch = do |
191 | akey <- akeyConnect (txAnnouncer tx) me theirKey | 191 | let akey = akeyConnect (txAnnouncer tx) me theirKey |
192 | atomically $ registerNodeCallback (toxRouting tox) (nic akey) | 192 | atomically $ registerNodeCallback (toxRouting tox) (nic akey) |
193 | scheduleSearch (txAnnouncer tx) akey meth pubkey | 193 | scheduleSearch (txAnnouncer tx) akey meth theirDhtKey |
194 | |||
195 | byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) | ||
196 | byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) | ||
197 | |||
198 | crypto = Tox.transportCrypto $ toxCryptoSessions tox | ||
199 | |||
200 | readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) | ||
201 | readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr | ||
202 | |||
203 | chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) | ||
204 | chillSesh = readNcVar Tox.ncState | ||
205 | |||
206 | activeSesh :: SockAddr -> STM Bool | ||
207 | activeSesh a = chillSesh a >>= return . \case | ||
208 | Just Established -> True | ||
209 | _ -> False | ||
210 | |||
211 | readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) | ||
212 | readCookie = readNcVar Tox.ncCookie | ||
213 | readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) | ||
214 | readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie | ||
215 | 194 | ||
216 | target :: NodeId | 195 | target :: NodeId |
217 | target = key2id $ dhtpk pubkey | 196 | target = key2id $ dhtpk theirDhtKey |
197 | |||
218 | meth :: SearchMethod Tox.DHTPublicKey | 198 | meth :: SearchMethod Tox.DHTPublicKey |
219 | meth = | 199 | meth = |
220 | SearchMethod | 200 | SearchMethod |
@@ -232,9 +212,6 @@ gotDhtPubkey pubkey tx theirKey = do | |||
232 | , rumoredAddress = assume akey | 212 | , rumoredAddress = assume akey |
233 | } | 213 | } |
234 | 214 | ||
235 | client :: Network.Tox.DHT.Handlers.Client | ||
236 | client = toxDHT tox | ||
237 | |||
238 | assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM () | 215 | assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM () |
239 | assume akey time addr ni = | 216 | assume akey time addr ni = |
240 | tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni) | 217 | tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni) |
@@ -242,17 +219,54 @@ gotDhtPubkey pubkey tx theirKey = do | |||
242 | observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () | 219 | observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () |
243 | observe akey time ni@(nodeAddr -> addr) = do | 220 | observe akey time ni@(nodeAddr -> addr) = do |
244 | tput XNodeinfoSearch $ show ("observation", akey, time, addr) | 221 | tput XNodeinfoSearch $ show ("observation", akey, time, addr) |
222 | setContactAddr time theirKey ni (txAccount tx) | ||
223 | |||
224 | gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO () | ||
225 | gotAddr ni@(nodeAddr -> addr) tx theirKey = do | ||
226 | dhtkey <- (fmap.fmap) snd $ | ||
227 | fmap join $ | ||
228 | atomically $ | ||
229 | traverse readTVar =<< fmap contactKeyPacket <$> getContact theirKey (txAccount tx) | ||
230 | forM_ dhtkey $ gotAddr' ni tx theirKey | ||
231 | |||
232 | gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO () | ||
233 | gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee | ||
234 | |||
235 | where | ||
236 | myPublicKey = toPublic $ userSecret (txAccount tx) | ||
237 | me = key2id myPublicKey | ||
238 | akey = akeyConnect (txAnnouncer tx) me theirKey | ||
239 | |||
240 | blee = do | ||
241 | scheduleImmediately (txAnnouncer tx) akey $ | ||
242 | ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) | ||
243 | |||
244 | tox :: Tox JabberClients | ||
245 | tox = txTox tx | ||
246 | |||
247 | byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) | ||
248 | byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) | ||
249 | |||
250 | crypto = Tox.transportCrypto $ toxCryptoSessions tox | ||
251 | |||
252 | readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) | ||
253 | readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr | ||
245 | 254 | ||
246 | contact <- getContact theirKey (txAccount tx) | 255 | chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) |
247 | join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case | 256 | chillSesh = readNcVar Tox.ncState |
248 | -- Don't update address if we already have one from the last minute. | 257 | |
249 | -- Really we need to be collecting a list of these. :-( | 258 | activeSesh :: SockAddr -> STM Bool |
250 | Just (t, addr') | addr == addr' && time - t < 60 -> return () | 259 | activeSesh a = chillSesh a >>= return . \case |
251 | _ -> do | 260 | Just Established -> True |
261 | _ -> False | ||
252 | 262 | ||
253 | scheduleImmediately (txAnnouncer tx) akey $ | 263 | readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) |
254 | ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) | 264 | readCookie = readNcVar Tox.ncCookie |
255 | setContactAddr time theirKey addr (txAccount tx) | 265 | readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) |
266 | readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie | ||
267 | |||
268 | client :: Network.Tox.DHT.Handlers.Client | ||
269 | client = toxDHT tox | ||
256 | 270 | ||
257 | getCookie | 271 | getCookie |
258 | :: NodeInfo | 272 | :: NodeInfo |
@@ -265,6 +279,7 @@ gotDhtPubkey pubkey tx theirKey = do | |||
265 | getCookie ni isActive getC ann akey now = getCookieAgain | 279 | getCookie ni isActive getC ann akey now = getCookieAgain |
266 | where | 280 | where |
267 | getCookieAgain = do | 281 | getCookieAgain = do |
282 | tput XNodeinfoSearch $ show ("getCookieAgain", akey) | ||
268 | mbContact <- getC | 283 | mbContact <- getC |
269 | case mbContact of | 284 | case mbContact of |
270 | Nothing -> return $ return () | 285 | Nothing -> return $ return () |
@@ -272,7 +287,7 @@ gotDhtPubkey pubkey tx theirKey = do | |||
272 | active <- isActive | 287 | active <- isActive |
273 | return $ when (not active) getCookieIO | 288 | return $ when (not active) getCookieIO |
274 | 289 | ||
275 | callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk pubkey) (toxCryptoSessions tox) (nodeAddr ni) | 290 | callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) |
276 | 291 | ||
277 | reschedule n f = scheduleRel ann akey f n | 292 | reschedule n f = scheduleRel ann akey f n |
278 | reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) | 293 | reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) |
@@ -281,6 +296,7 @@ gotDhtPubkey pubkey tx theirKey = do | |||
281 | 296 | ||
282 | getCookieIO :: IO () | 297 | getCookieIO :: IO () |
283 | getCookieIO = do | 298 | getCookieIO = do |
299 | dput XUnused "getCookieIO - entered" | ||
284 | cookieRequest crypto client myPublicKey ni >>= \case | 300 | cookieRequest crypto client myPublicKey ni >>= \case |
285 | Nothing -> atomically $ reschedule' 5 (const getCookieAgain) | 301 | Nothing -> atomically $ reschedule' 5 (const getCookieAgain) |
286 | Just cookie -> do | 302 | Just cookie -> do |
@@ -288,15 +304,21 @@ gotDhtPubkey pubkey tx theirKey = do | |||
288 | cookieCreationStamp <- getPOSIXTime | 304 | cookieCreationStamp <- getPOSIXTime |
289 | let shaker :: POSIXTime -> STM (IO ()) | 305 | let shaker :: POSIXTime -> STM (IO ()) |
290 | shaker now = do | 306 | shaker now = do |
291 | if (now > cookieCreationStamp + cookieMaxAge) | 307 | active <- isActive |
292 | then return $ dput XUnused "getCookieIO" | 308 | if (active) |
293 | else do | 309 | then return $ return () |
294 | reschedule' 5 shaker | 310 | else if (now > cookieCreationStamp + cookieMaxAge) |
295 | return . void $ callRealShakeHands cookie | 311 | then return $ |
312 | dput XUnused "getCookieIO/shaker - cookie expired" >> | ||
313 | getCookieIO | ||
314 | else do | ||
315 | reschedule' 5 shaker | ||
316 | return . void $ callRealShakeHands cookie | ||
296 | atomically $ reschedule' 5 shaker | 317 | atomically $ reschedule' 5 shaker |
297 | 318 | ||
298 | realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool | 319 | realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool |
299 | realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do | 320 | realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do |
321 | dput XUnused "realShakeHands" | ||
300 | let hp = | 322 | let hp = |
301 | HParam | 323 | HParam |
302 | { hpOtherCookie = cookie | 324 | { hpOtherCookie = cookie |
@@ -318,7 +340,7 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do | |||
318 | dispatch :: ToxToXMPP -> ContactEvent -> IO () | 340 | dispatch :: ToxToXMPP -> ContactEvent -> IO () |
319 | dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey | 341 | dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey |
320 | dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey | 342 | dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey |
321 | dispatch tx (AddrChange theirkey saddr) = return () -- todo | 343 | dispatch tx (AddrChange theirKey saddr) = gotAddr saddr tx theirKey |
322 | dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey | 344 | dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey |
323 | dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey | 345 | dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey |
324 | dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey | 346 | dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey |
@@ -352,12 +374,12 @@ interweave :: [a] -> [a] -> [a] | |||
352 | interweave [] ys = ys | 374 | interweave [] ys = ys |
353 | interweave (x:xs) ys = x : interweave ys xs | 375 | interweave (x:xs) ys = x : interweave ys xs |
354 | 376 | ||
355 | akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey | 377 | akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey |
356 | akeyDHTKeyShare announcer me them = atomically $ do | 378 | akeyDHTKeyShare announcer me them = |
357 | packAnnounceKey announcer $ "dhtkey:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) | 379 | packAnnounceKey announcer $ "dhtkey:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) |
358 | 380 | ||
359 | akeyConnect :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey | 381 | akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey |
360 | akeyConnect announcer me them = atomically $ do | 382 | akeyConnect announcer me them = |
361 | packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) | 383 | packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) |
362 | 384 | ||
363 | 385 | ||
@@ -407,7 +429,7 @@ startConnecting0 tx them contact = do | |||
407 | me = key2id mypub | 429 | me = key2id mypub |
408 | soliciting <- checkSoliciting (txPresence tx) mypub them contact | 430 | soliciting <- checkSoliciting (txPresence tx) mypub them contact |
409 | when wanted $ do | 431 | when wanted $ do |
410 | akey <- akeyDHTKeyShare announcer me them | 432 | akey <- return $ akeyDHTKeyShare announcer me them |
411 | -- We send this packet every 30 seconds if there is more | 433 | -- We send this packet every 30 seconds if there is more |
412 | -- than one peer (in the 8) that says they our friend is | 434 | -- than one peer (in the 8) that says they our friend is |
413 | -- announced on them. This packet can also be sent through | 435 | -- announced on them. This packet can also be sent through |
@@ -464,9 +486,9 @@ startConnecting tx them = do | |||
464 | stopConnecting :: ToxToXMPP -> PublicKey -> IO () | 486 | stopConnecting :: ToxToXMPP -> PublicKey -> IO () |
465 | stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do | 487 | stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do |
466 | dput XMan $ "STOP CONNECTING " ++ show (key2id them) | 488 | dput XMan $ "STOP CONNECTING " ++ show (key2id them) |
467 | let pub = toPublic $ userSecret acnt | 489 | let pub = toPublic $ userSecret acnt |
468 | me = key2id pub | 490 | me = key2id pub |
469 | akey <- akeyDHTKeyShare announcer me them | 491 | akey = akeyDHTKeyShare announcer me them |
470 | cancel announcer akey | 492 | cancel announcer akey |
471 | 493 | ||
472 | forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId | 494 | forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId |
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index c03df3cc..9b5abb22 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -1065,7 +1065,7 @@ clientSession s@Session{..} sock cnum h = do | |||
1065 | rs <- atomically $ do | 1065 | rs <- atomically $ do |
1066 | as <- scheduleToList announcer | 1066 | as <- scheduleToList announcer |
1067 | forM (as) $ \(k,ptm,item) -> do | 1067 | forM (as) $ \(k,ptm,item) -> do |
1068 | kstr <- unpackAnnounceKey announcer k | 1068 | let kstr = unpackAnnounceKey announcer k |
1069 | return [ if ptm==0 then "now" | 1069 | return [ if ptm==0 then "now" |
1070 | else show (ptm - now) | 1070 | else show (ptm - now) |
1071 | , show (itemStatusNum item) | 1071 | , show (itemStatusNum item) |
@@ -1124,7 +1124,7 @@ clientSession s@Session{..} sock cnum h = do | |||
1124 | -- return $ hPutClient h "Type matches." | 1124 | -- return $ hPutClient h "Type matches." |
1125 | dta <- either (const Nothing) Just $ announceParseData dtastr | 1125 | dta <- either (const Nothing) Just $ announceParseData dtastr |
1126 | return $ do | 1126 | return $ do |
1127 | akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) | 1127 | let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr) |
1128 | doitR op announcer | 1128 | doitR op announcer |
1129 | akey | 1129 | akey |
1130 | (AnnounceMethod qsearch asend | 1130 | (AnnounceMethod qsearch asend |
@@ -1150,7 +1150,7 @@ clientSession s@Session{..} sock cnum h = do | |||
1150 | dta <- either (const Nothing) Just $ announceParseData dtastr | 1150 | dta <- either (const Nothing) Just $ announceParseData dtastr |
1151 | pub <- selectedKey | 1151 | pub <- selectedKey |
1152 | return $ do | 1152 | return $ do |
1153 | akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) | 1153 | let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr) |
1154 | doitL op announcer | 1154 | doitL op announcer |
1155 | akey | 1155 | akey |
1156 | (SearchMethod qsearch (asend pub) | 1156 | (SearchMethod qsearch (asend pub) |
@@ -1352,7 +1352,7 @@ netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) exes paramStr = | |||
1352 | Nothing -> hPutClient h "Unable to find account for selected key" | 1352 | Nothing -> hPutClient h "Unable to find account for selected key" |
1353 | Just account -> do | 1353 | Just account -> do |
1354 | now <- getPOSIXTime | 1354 | now <- getPOSIXTime |
1355 | atomically $ setContactAddr now their_pub their_addr account | 1355 | atomically $ setContactAddr now their_pub (_fixme their_addr) account |
1356 | sessions <- Tox.netCrypto tox sec their_pub | 1356 | sessions <- Tox.netCrypto tox sec their_pub |
1357 | exeDir <- takeDirectory <$> getExecutablePath | 1357 | exeDir <- takeDirectory <$> getExecutablePath |
1358 | forM_ sessions $ \session -> do | 1358 | forM_ sessions $ \session -> do |
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index f7cf7b1e..cebbebfb 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs | |||
@@ -261,7 +261,7 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do | |||
261 | -- Convert to NodeInfo, so we can send cookieRequest | 261 | -- Convert to NodeInfo, so we can send cookieRequest |
262 | let crypto = toxCryptoKeys tox | 262 | let crypto = toxCryptoKeys tox |
263 | client = toxDHT tox | 263 | client = toxDHT tox |
264 | case nodeInfo (key2id theirDhtKey) saddr of | 264 | case nodeInfo (key2id theirDhtKey) (nodeAddr saddr) of |
265 | Left e -> dput XNetCrypto ("netCrypto: nodeInfo fail... " ++ e) >> return [] | 265 | Left e -> dput XNetCrypto ("netCrypto: nodeInfo fail... " ++ e) >> return [] |
266 | Right ni -> do | 266 | Right ni -> do |
267 | mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni | 267 | mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni |
@@ -282,11 +282,11 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do | |||
282 | newsession <- generateSecretKey | 282 | newsession <- generateSecretKey |
283 | timestamp <- getPOSIXTime | 283 | timestamp <- getPOSIXTime |
284 | (myhandshake,ioAction) | 284 | (myhandshake,ioAction) |
285 | <- atomically $ freshCryptoSession (toxCryptoSessions tox) saddr newsession timestamp hp | 285 | <- atomically $ freshCryptoSession (toxCryptoSessions tox) (nodeAddr saddr) newsession timestamp hp |
286 | ioAction | 286 | ioAction |
287 | -- send handshake | 287 | -- send handshake |
288 | forM myhandshake $ \response_handshake -> do | 288 | forM myhandshake $ \response_handshake -> do |
289 | sendHandshake (toxCryptoSessions tox) saddr response_handshake | 289 | sendHandshake (toxCryptoSessions tox) (nodeAddr saddr) response_handshake |
290 | let secnum :: Double | 290 | let secnum :: Double |
291 | secnum = fromIntegral millisecs / 1000000 | 291 | secnum = fromIntegral millisecs / 1000000 |
292 | delay = (millisecs * 5 `div` 4) | 292 | delay = (millisecs * 5 `div` 4) |
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs index 3f794197..1970b782 100644 --- a/src/Network/Tox/ContactInfo.hs +++ b/src/Network/Tox/ContactInfo.hs | |||
@@ -1,4 +1,5 @@ | |||
1 | {-# LANGUAGE NamedFieldPuns #-} | 1 | {-# LANGUAGE NamedFieldPuns #-} |
2 | {-# LANGUAGE LambdaCase #-} | ||
2 | module Network.Tox.ContactInfo where | 3 | module Network.Tox.ContactInfo where |
3 | 4 | ||
4 | import Connection | 5 | import Connection |
@@ -30,13 +31,13 @@ data Account extra = Account | |||
30 | 31 | ||
31 | data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } | 32 | data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } |
32 | | PolicyChange { contact :: PublicKey, policyChange :: Policy } | 33 | | PolicyChange { contact :: PublicKey, policyChange :: Policy } |
33 | | AddrChange { contact :: PublicKey, addrChange :: SockAddr } | 34 | | AddrChange { contact :: PublicKey, addrChange :: NodeInfo } |
34 | | SessionEstablished { contact :: PublicKey } | 35 | | SessionEstablished { contact :: PublicKey } |
35 | | SessionTerminated { contact :: PublicKey } | 36 | | SessionTerminated { contact :: PublicKey } |
36 | 37 | ||
37 | data Contact = Contact | 38 | data Contact = Contact |
38 | { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey)) | 39 | { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey)) |
39 | , contactLastSeenAddr :: TVar (Maybe (POSIXTime,SockAddr)) | 40 | , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo)) |
40 | , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest)) | 41 | , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest)) |
41 | , contactPolicy :: TVar (Maybe Connection.Policy) | 42 | , contactPolicy :: TVar (Maybe Connection.Policy) |
42 | } | 43 | } |
@@ -97,7 +98,7 @@ onionUpdate now (Onion.OnionFriendRequest fr) contact | |||
97 | policyUpdate :: Policy -> Contact -> STM () | 98 | policyUpdate :: Policy -> Contact -> STM () |
98 | policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy | 99 | policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy |
99 | 100 | ||
100 | addrUpdate :: POSIXTime -> SockAddr -> Contact -> STM () | 101 | addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM () |
101 | addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) | 102 | addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) |
102 | 103 | ||
103 | setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () | 104 | setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () |
@@ -105,10 +106,16 @@ setContactPolicy remoteUserKey policy acc = do | |||
105 | updateAccount' remoteUserKey acc $ policyUpdate policy | 106 | updateAccount' remoteUserKey acc $ policyUpdate policy |
106 | writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy | 107 | writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy |
107 | 108 | ||
108 | setContactAddr :: POSIXTime -> PublicKey -> SockAddr -> Account extra -> STM () | 109 | setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM () |
109 | setContactAddr now remoteUserKey addr acc = do | 110 | setContactAddr now remoteUserKey addr acc = do |
110 | updateAccount' remoteUserKey acc $ addrUpdate now addr | 111 | contact <- getContact remoteUserKey acc |
111 | writeTChan (eventChan acc) $ AddrChange remoteUserKey addr | 112 | let update = updateAccount' remoteUserKey acc $ addrUpdate now addr |
113 | let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr | ||
114 | join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case | ||
115 | Just (_, a) | addr == a -> update -- updates time only | ||
116 | Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old | ||
117 | Nothing -> update >> notify -- or if we don't have any | ||
118 | _ -> return () -- otherwise just wait | ||
112 | 119 | ||
113 | setEstablished :: POSIXTime -> PublicKey -> Account extra -> STM () | 120 | setEstablished :: POSIXTime -> PublicKey -> Account extra -> STM () |
114 | setEstablished now remoteUserKey acc = | 121 | setEstablished now remoteUserKey acc = |