summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Announcer.hs8
-rw-r--r--Connection/Tox.hs8
-rw-r--r--Connection/Tox/Threads.hs6
-rw-r--r--ToxManager.hs4
-rw-r--r--ToxToXMPP.hs128
-rw-r--r--examples/dhtd.hs8
-rw-r--r--src/Network/Tox.hs6
-rw-r--r--src/Network/Tox/ContactInfo.hs19
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
46instance Show AnnounceKey where 46instance Show AnnounceKey where
47 show (AnnounceKey bs) = "AnnounceKey " ++ show (Char8.unpack bs) 47 show (AnnounceKey bs) = "AnnounceKey " ++ show (Char8.unpack bs)
48 48
49packAnnounceKey :: Announcer -> String -> STM AnnounceKey 49packAnnounceKey :: Announcer -> String -> AnnounceKey
50packAnnounceKey _ = return . AnnounceKey . Char8.pack 50packAnnounceKey _ = AnnounceKey . Char8.pack
51 51
52unpackAnnounceKey :: Announcer -> AnnounceKey -> STM String 52unpackAnnounceKey :: Announcer -> AnnounceKey -> String
53unpackAnnounceKey _ (AnnounceKey bs) = return $ Char8.unpack bs 53unpackAnnounceKey _ (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
246stringToKey_ :: String -> Maybe Key 246stringToKey_ :: 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
159data NNS a b c = NNS { -- NetcryptoNegotiationState 159data 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
174gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () 174gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
175gotDhtPubkey pubkey tx theirKey = do 175gotDhtPubkey 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
224gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO ()
225gotAddr 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
232gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO ()
233gotAddr' 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
298realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool 319realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool
299realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do 320realShakeHands 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
318dispatch :: ToxToXMPP -> ContactEvent -> IO () 340dispatch :: ToxToXMPP -> ContactEvent -> IO ()
319dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey 341dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey
320dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey 342dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey
321dispatch tx (AddrChange theirkey saddr) = return () -- todo 343dispatch tx (AddrChange theirKey saddr) = gotAddr saddr tx theirKey
322dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey 344dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey
323dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey 345dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey
324dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey 346dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey
@@ -352,12 +374,12 @@ interweave :: [a] -> [a] -> [a]
352interweave [] ys = ys 374interweave [] ys = ys
353interweave (x:xs) ys = x : interweave ys xs 375interweave (x:xs) ys = x : interweave ys xs
354 376
355akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey 377akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey
356akeyDHTKeyShare announcer me them = atomically $ do 378akeyDHTKeyShare 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
359akeyConnect :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey 381akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey
360akeyConnect announcer me them = atomically $ do 382akeyConnect 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
464stopConnecting :: ToxToXMPP -> PublicKey -> IO () 486stopConnecting :: ToxToXMPP -> PublicKey -> IO ()
465stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do 487stopConnecting 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
472forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId 494forkAccountWatcher :: 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 #-}
2module Network.Tox.ContactInfo where 3module Network.Tox.ContactInfo where
3 4
4import Connection 5import Connection
@@ -30,13 +31,13 @@ data Account extra = Account
30 31
31data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } 32data 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
37data Contact = Contact 38data 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
97policyUpdate :: Policy -> Contact -> STM () 98policyUpdate :: Policy -> Contact -> STM ()
98policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy 99policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy
99 100
100addrUpdate :: POSIXTime -> SockAddr -> Contact -> STM () 101addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM ()
101addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) 102addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)
102 103
103setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () 104setContactPolicy :: 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
108setContactAddr :: POSIXTime -> PublicKey -> SockAddr -> Account extra -> STM () 109setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM ()
109setContactAddr now remoteUserKey addr acc = do 110setContactAddr 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
113setEstablished :: POSIXTime -> PublicKey -> Account extra -> STM () 120setEstablished :: POSIXTime -> PublicKey -> Account extra -> STM ()
114setEstablished now remoteUserKey acc = 121setEstablished now remoteUserKey acc =