summaryrefslogtreecommitdiff
path: root/dht
diff options
context:
space:
mode:
Diffstat (limited to 'dht')
-rw-r--r--dht/OnionRouter.hs10
-rw-r--r--dht/src/Network/BitTorrent/MainlineDHT.hs2
-rw-r--r--dht/src/Network/QueryResponse.hs33
-rw-r--r--dht/src/Network/Tox.hs4
-rw-r--r--dht/src/Network/Tox/DHT/Handlers.hs4
-rw-r--r--dht/src/Network/Tox/Onion/Handlers.hs15
-rw-r--r--dht/src/Network/Tox/TCP.hs4
7 files changed, 37 insertions, 35 deletions
diff --git a/dht/OnionRouter.hs b/dht/OnionRouter.hs
index 1c16db6d..bdaf04b2 100644
--- a/dht/OnionRouter.hs
+++ b/dht/OnionRouter.hs
@@ -566,8 +566,8 @@ lookupRoute or ni (RouteId rid) = do
566 mb <- atomically $ readArray (routeMap or) rid 566 mb <- atomically $ readArray (routeMap or) rid
567 return $ storedRoute <$> mb 567 return $ storedRoute <$> mb
568 568
569lookupTimeout :: OnionRouter -> Nonce8 -> OnionDestination r -> STM (OnionDestination RouteId, Int) 569lookupTimeout :: OnionRouter -> OnionDestination r -> STM (OnionDestination RouteId, Int)
570lookupTimeout or n8 (OnionDestination asel ni Nothing) = do 570lookupTimeout or (OnionDestination asel ni Nothing) = do
571 let RouteId rid = routeId (nodeId ni) 571 let RouteId rid = routeId (nodeId ni)
572 mrr <- readArray (routeMap or) rid 572 mrr <- readArray (routeMap or) rid
573 writeTChan (routeLog or) $ unwords ["ONION lookupTimeout " ,show rid] 573 writeTChan (routeLog or) $ unwords ["ONION lookupTimeout " ,show rid]
@@ -579,7 +579,7 @@ hookQueries :: OnionRouter -> (tid -> Nonce8)
579 -> TransactionMethods d tid (OnionDestination RouteId) x 579 -> TransactionMethods d tid (OnionDestination RouteId) x
580 -> TransactionMethods d tid (OnionDestination RouteId) x 580 -> TransactionMethods d tid (OnionDestination RouteId) x
581hookQueries or t8 tmethods = TransactionMethods 581hookQueries or t8 tmethods = TransactionMethods
582 { dispatchRegister = \getTimeout now mvar od d -> {-# SCC "hookQ.dispatchRegister" #-} do -- :: MVar x -> d -> STM (tid, d) 582 { dispatchRegister = \nowPlusExpiry mvar od d -> {-# SCC "hookQ.dispatchRegister" #-} do -- :: MVar x -> d -> STM (tid, d)
583 let ni = onionNodeInfo od 583 let ni = onionNodeInfo od
584 rid@(RouteId ridn) = fromMaybe (routeId (nodeId ni)) $ onionRouteSpec od 584 rid@(RouteId ridn) = fromMaybe (routeId (nodeId ni)) $ onionRouteSpec od
585 wanted <- {-# SCC "hookQ.wanted" #-} (readArray (pendingRoutes or) ridn) 585 wanted <- {-# SCC "hookQ.wanted" #-} (readArray (pendingRoutes or) ridn)
@@ -588,7 +588,7 @@ hookQueries or t8 tmethods = TransactionMethods
588 check $ fromMaybe False $ do 588 check $ fromMaybe False $ do
589 RouteRecord{routeVersion=rv} <- {-# SCC "hookQ.mr" #-} mr 589 RouteRecord{routeVersion=rv} <- {-# SCC "hookQ.mr" #-} mr
590 return $ wanted <= rv 590 return $ wanted <= rv
591 ((tid,a,expiry),d') <- dispatchRegister tmethods getTimeout now mvar od d 591 (tid,d') <- dispatchRegister tmethods nowPlusExpiry mvar od d
592 let Nonce8 w8 = t8 tid 592 let Nonce8 w8 = t8 tid
593 od' = case od of 593 od' = case od of
594 OnionDestination {} -> od { onionRouteSpec = Just rid } 594 OnionDestination {} -> od { onionRouteSpec = Just rid }
@@ -600,7 +600,7 @@ hookQueries or t8 tmethods = TransactionMethods
600 -- check $ W64.size pqs < 20 600 -- check $ W64.size pqs < 20
601 modifyTVar' (pendingQueries or) (W64.insert w8 pq) 601 modifyTVar' (pendingQueries or) (W64.insert w8 pq)
602 writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show (Just $ pendingVersion pq,w8), ":=", show ni ] 602 writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show (Just $ pendingVersion pq,w8), ":=", show ni ]
603 return ((tid,a,expiry),d') 603 return (tid,d')
604 , dispatchResponse = \tid x d -> {-# SCC "hookQ.dispatchResponse" #-} do -- :: tid -> x -> d -> STM (d, IO ()) 604 , dispatchResponse = \tid x d -> {-# SCC "hookQ.dispatchResponse" #-} do -- :: tid -> x -> d -> STM (d, IO ())
605 let Nonce8 w8 = t8 tid 605 let Nonce8 w8 = t8 tid
606 mb <- W64.lookup w8 <$> readTVar (pendingQueries or) 606 mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs
index 2ea2551e..7589f538 100644
--- a/dht/src/Network/BitTorrent/MainlineDHT.hs
+++ b/dht/src/Network/BitTorrent/MainlineDHT.hs
@@ -1072,7 +1072,7 @@ mainlineSerializeer :: (BEncode a2, BEncode a1) =>
1072 -> MethodSerializer 1072 -> MethodSerializer
1073 TransactionId NodeInfo (Message BValue) Method a1 (Either Error b) 1073 TransactionId NodeInfo (Message BValue) Method a1 (Either Error b)
1074mainlineSerializeer meth unwrap client = MethodSerializer 1074mainlineSerializeer meth unwrap client = MethodSerializer
1075 { methodTimeout = \_ ni -> return (ni, 5000000) 1075 { methodTimeout = \ni -> return (ni, 5000000)
1076 , method = meth 1076 , method = meth
1077 , wrapQuery = encodeQueryPayload meth (isReadonlyClient client) 1077 , wrapQuery = encodeQueryPayload meth (isReadonlyClient client)
1078 , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack) 1078 , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack)
diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs
index 9c33b911..5fcd1989 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/dht/src/Network/QueryResponse.hs
@@ -217,11 +217,11 @@ asyncQuery_ (Client net d err pending whoami _) meth q addr0 withResponse = do
217 now <- getPOSIXTime 217 now <- getPOSIXTime
218 (tid,addr,expiry) <- atomically $ do 218 (tid,addr,expiry) <- atomically $ do
219 tbl <- readTVar pending 219 tbl <- readTVar pending
220 ((tid,addr,expiry), tbl') <- dispatchRegister (tableMethods d) 220 (addr,expiry) <- methodTimeout meth addr0
221 (methodTimeout meth) 221 (tid, tbl') <- dispatchRegister (tableMethods d)
222 now 222 (now + microsecondsDiff expiry)
223 (withResponse . fmap (unwrapResponse meth)) 223 (withResponse . fmap (unwrapResponse meth))
224 addr0 224 addr -- XXX: Should be addr0 or addr?
225 tbl 225 tbl
226 -- (addr,expiry) <- methodTimeout meth tid addr0 226 -- (addr,expiry) <- methodTimeout meth tid addr0
227 writeTVar pending tbl' 227 writeTVar pending tbl'
@@ -365,7 +365,7 @@ data MethodSerializer tid addr x meth a b = MethodSerializer
365 { -- | Returns the microseconds to wait for a response to this query being 365 { -- | Returns the microseconds to wait for a response to this query being
366 -- sent to the given address. The /addr/ may also be modified to add 366 -- sent to the given address. The /addr/ may also be modified to add
367 -- routing information. 367 -- routing information.
368 methodTimeout :: tid -> addr -> STM (addr,Int) 368 methodTimeout :: addr -> STM (addr,Int)
369 -- | A method identifier used for error reporting. This needn't be the 369 -- | A method identifier used for error reporting. This needn't be the
370 -- same as the /meth/ argument to 'MethodHandler', but it is suggested. 370 -- same as the /meth/ argument to 'MethodHandler', but it is suggested.
371 , method :: meth 371 , method :: meth
@@ -385,21 +385,25 @@ data MethodSerializer tid addr x meth a b = MethodSerializer
385-- 385--
386-- The type variable /d/ is used to represent the current state of the 386-- The type variable /d/ is used to represent the current state of the
387-- transaction generator and the table of pending transactions. 387-- transaction generator and the table of pending transactions.
388data TransactionMethods d tid addr x = TransactionMethods 388data TransactionMethods d qid addr x = TransactionMethods
389 { 389 {
390 -- | Before a query is sent, this function stores an 'MVar' to which the 390 -- | Before a query is sent, this function stores an 'MVar' to which the
391 -- response will be written too. The returned /tid/ is a transaction id 391 -- response will be written too. The returned /qid/ is a transaction id
392 -- that can be used to forget the 'MVar' if the remote peer is not 392 -- that can be used to forget the 'MVar' if the remote peer is not
393 -- responding. 393 -- responding.
394 dispatchRegister :: (tid -> addr -> STM (addr,Int)) -> POSIXTime -> (Maybe x -> IO ()) -> addr -> d -> STM ((tid,addr,Int), d) 394 dispatchRegister :: POSIXTime -- time of expiry
395 -> (Maybe x -> IO ()) -- callback upon response (or timeout)
396 -> addr
397 -> d
398 -> STM (qid, d)
395 -- | This method is invoked when an incoming packet /x/ indicates it is 399 -- | This method is invoked when an incoming packet /x/ indicates it is
396 -- a response to the transaction with id /tid/. The returned IO action 400 -- a response to the transaction with id /qid/. The returned IO action
397 -- will write the packet to the correct 'MVar' thus completing the 401 -- will write the packet to the correct 'MVar' thus completing the
398 -- dispatch. 402 -- dispatch.
399 , dispatchResponse :: tid -> x -> d -> STM (d, IO ()) 403 , dispatchResponse :: qid -> x -> d -> STM (d, IO ())
400 -- | When a timeout interval elapses, this method is called to remove the 404 -- | When a timeout interval elapses, this method is called to remove the
401 -- transaction from the table. 405 -- transaction from the table.
402 , dispatchCancel :: tid -> d -> STM d 406 , dispatchCancel :: qid -> d -> STM d
403 } 407 }
404 408
405-- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a 409-- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a
@@ -424,11 +428,10 @@ transactionMethods' ::
424 -> TransactionMethods (g,t a) tid addr x 428 -> TransactionMethods (g,t a) tid addr x
425transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods 429transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods
426 { dispatchCancel = \tid (g,t) -> return (g, delete tid t) 430 { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
427 , dispatchRegister = \getTimeout now v a0 (g,t) -> do 431 , dispatchRegister = \nowPlusExpiry v a (g,t) -> do
428 let (tid,g') = generate g 432 let (tid,g') = generate g
429 (a,expiry) <- getTimeout tid a0 433 let t' = insert tid (store v) nowPlusExpiry t -- (now + microsecondsDiff expiry) t
430 let t' = insert tid (store v) (now + microsecondsDiff expiry) t 434 return ( tid, (g',t') )
431 return ( (tid,a,expiry), (g',t') )
432 , dispatchResponse = \tid x (g,t) -> 435 , dispatchResponse = \tid x (g,t) ->
433 case lookup tid t of 436 case lookup tid t of
434 Just v -> let t' = delete tid t 437 Just v -> let t' = delete tid t
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 8a952aa4..34e63ad8 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -391,8 +391,8 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
391 , toxRelayServer = Nothing 391 , toxRelayServer = Nothing
392 } 392 }
393 393
394onionTimeout :: Tox extra -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int) 394onionTimeout :: Tox extra -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
395onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od 395onionTimeout Tox { toxOnionRoutes = or } od = lookupTimeout or od
396 396
397routing4nodeInfo :: DHT.Routing -> IO NodeInfo 397routing4nodeInfo :: DHT.Routing -> IO NodeInfo
398routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv 398routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index 1eec93b9..e97cab96 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -330,7 +330,7 @@ serializer :: PacketKind
330 -> (Message -> Maybe (Asymm (Nonce8,pong))) 330 -> (Message -> Maybe (Asymm (Nonce8,pong)))
331 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong) 331 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
332serializer pktkind mkping mkpong = MethodSerializer 332serializer pktkind mkping mkpong = MethodSerializer
333 { methodTimeout = \tid addr -> return (addr, 5000000) 333 { methodTimeout = \addr -> return (addr, 5000000)
334 , method = pktkind 334 , method = pktkind
335 -- wrapQuery :: tid -> addr -> addr -> qry -> x 335 -- wrapQuery :: tid -> addr -> addr -> qry -> x
336 , wrapQuery = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping) 336 , wrapQuery = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping)
@@ -376,7 +376,7 @@ cookieRequest crypto client localUserKey addr = do
376 nid = id2key $ nodeId addr 376 nid = id2key $ nodeId addr
377 cookieSerializer 377 cookieSerializer
378 = MethodSerializer 378 = MethodSerializer
379 { methodTimeout = \tid addr -> return (addr, 5000000) 379 { methodTimeout = \addr -> return (addr, 5000000)
380 , method = CookieRequestType 380 , method = CookieRequestType
381 , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr) 381 , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
382 , unwrapResponse = fmap snd . unCookie 382 , unwrapResponse = fmap snd . unCookie
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
index 25713aa1..3ea7395f 100644
--- a/dht/src/Network/Tox/Onion/Handlers.hs
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -212,7 +212,7 @@ handlers net routing toks keydb AnnounceType
212handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net 212handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
213 213
214 214
215toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) 215toxidSearch :: (OnionDestination r -> STM (OnionDestination r, Int))
216 -> TransportCrypto 216 -> TransportCrypto
217 -> Client r 217 -> Client r
218 -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous 218 -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
@@ -224,7 +224,7 @@ toxidSearch getTimeout crypto client = Search
224 , searchK = 6 224 , searchK = 6
225 } 225 }
226 226
227announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) 227announceSerializer :: (OnionDestination r -> STM (OnionDestination r, Int))
228 -> MethodSerializer 228 -> MethodSerializer
229 TransactionId 229 TransactionId
230 (OnionDestination r) 230 (OnionDestination r)
@@ -276,7 +276,7 @@ unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
276-- started. 276-- started.
277 277
278 278
279sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) 279sendOnion :: (OnionDestination r -> STM (OnionDestination r, Int))
280 -> Client r 280 -> Client r
281 -> AnnounceRequest 281 -> AnnounceRequest
282 -> OnionDestination r 282 -> OnionDestination r
@@ -291,8 +291,7 @@ sendOnion getTimeout client req oaddr unwrap =
291 (return . Just . unwrap (onionNodeInfo oaddr)) 291 (return . Just . unwrap (onionNodeInfo oaddr))
292 $ join mb 292 $ join mb
293 293
294asyncOnion :: (TransactionId 294asyncOnion :: (OnionDestination r -> STM (OnionDestination r, Int))
295 -> OnionDestination r -> STM (OnionDestination r, Int))
296 -> QR.Client 295 -> QR.Client
297 err 296 err
298 PacketKind 297 PacketKind
@@ -316,7 +315,7 @@ asyncOnion getTimeout client req oaddr unwrap go =
316 315
317 316
318-- | Lookup the secret counterpart for a given alias key. 317-- | Lookup the secret counterpart for a given alias key.
319getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) 318getRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int))
320 -> TransportCrypto 319 -> TransportCrypto
321 -> Client r 320 -> Client r
322 -> NodeId 321 -> NodeId
@@ -334,7 +333,7 @@ getRendezvous getTimeout crypto client nid ni = do
334 (unwrapAnnounceResponse rkey) 333 (unwrapAnnounceResponse rkey)
335 334
336asyncGetRendezvous 335asyncGetRendezvous
337 :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) 336 :: (OnionDestination r -> STM (OnionDestination r, Int))
338 -> TransportCrypto 337 -> TransportCrypto
339 -> Client r 338 -> Client r
340 -> NodeId 339 -> NodeId
@@ -353,7 +352,7 @@ asyncGetRendezvous getTimeout crypto client nid ni go = do
353 (unwrapAnnounceResponse rkey) 352 (unwrapAnnounceResponse rkey)
354 go 353 go
355 354
356putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) 355putRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int))
357 -> TransportCrypto 356 -> TransportCrypto
358 -> Client r 357 -> Client r
359 -> PublicKey 358 -> PublicKey
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index d0d67f25..e80a22d1 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -229,7 +229,7 @@ getUDPNodes' tcp seeking dst0 = do
229 AnnounceRequest 229 AnnounceRequest
230 (Either String AnnounceResponse) 230 (Either String AnnounceResponse)
231 meth = MethodSerializer 231 meth = MethodSerializer
232 { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout 232 { methodTimeout = \addr -> return (addr,12000000) -- 12 second timeout
233 , method = OnionPacketID -- meth 233 , method = OnionPacketID -- meth
234 , wrapQuery = \n8 src gateway x -> (,) True $ 234 , wrapQuery = \n8 src gateway x -> (,) True $
235 OnionPacket n24 $ Addressed (UDP.nodeAddr dst) 235 OnionPacket n24 $ Addressed (UDP.nodeAddr dst)
@@ -269,7 +269,7 @@ tcpPing client dst = do
269 where meth = MethodSerializer 269 where meth = MethodSerializer
270 { wrapQuery = \n8 src dst () -> (True,RelayPing n8) 270 { wrapQuery = \n8 src dst () -> (True,RelayPing n8)
271 , unwrapResponse = \_ -> () 271 , unwrapResponse = \_ -> ()
272 , methodTimeout = \n8 dst -> return (dst,5000000) 272 , methodTimeout = \dst -> return (dst,5000000)
273 , method = PingPacket 273 , method = PingPacket
274 } 274 }
275 275