summaryrefslogtreecommitdiff
path: root/dht/src/Network/Tox/Onion/Routes.hs
diff options
context:
space:
mode:
Diffstat (limited to 'dht/src/Network/Tox/Onion/Routes.hs')
-rw-r--r--dht/src/Network/Tox/Onion/Routes.hs730
1 files changed, 730 insertions, 0 deletions
diff --git a/dht/src/Network/Tox/Onion/Routes.hs b/dht/src/Network/Tox/Onion/Routes.hs
new file mode 100644
index 00000000..c054b99e
--- /dev/null
+++ b/dht/src/Network/Tox/Onion/Routes.hs
@@ -0,0 +1,730 @@
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE NondecreasingIndentation #-}
3{-# LANGUAGE RankNTypes #-}
4module Network.Tox.Onion.Routes where
5
6import Control.Concurrent.ThreadUtil
7import Crypto.Tox
8import Network.Address
9import Network.Kademlia
10import Network.Kademlia.Bootstrap
11import Network.Kademlia.Routing as R
12import Network.Kademlia.Search
13import Network.QueryResponse
14import Network.QueryResponse.TCP
15import Network.Tox.NodeId
16import Network.Tox.Onion.Transport as Onion
17import qualified Data.Tox.Relay as TCP
18import qualified Network.Tox.TCP as TCP
19import qualified TCPProber as TCP
20
21import Control.Arrow
22import Control.Concurrent.STM
23import Control.Concurrent.STM.TArray
24import Control.Monad
25import Crypto.Random
26import Data.Array.MArray
27import Data.Bits
28import Data.Bool
29import Data.List
30import qualified Data.ByteString as B
31import Data.Functor.Identity
32import Data.Hashable
33import qualified Data.HashMap.Strict as HashMap
34 ;import Data.HashMap.Strict (HashMap)
35import qualified Data.IntMap as IntMap
36 ;import Data.IntMap (IntMap)
37import Data.Maybe
38import Data.Ord
39import qualified Data.Serialize as S
40import Data.Time.Clock.POSIX
41import Data.Typeable
42import Data.Word
43import qualified Data.Word64Map as W64
44 ;import Data.Word64Map (Word64Map, fitsInInt)
45import Network.Socket
46import System.Endian
47import System.Timeout
48
49-- Toxcore saves a maximum of 12 paths: 6 paths are reserved for announcing
50-- ourselves and 6 others are used to search for friends.
51--
52-- Note: This is pointless because a man-in-the-middle attack currently makes
53-- it trivial to glean friend relationships: the storing node can swap the
54-- published to-route key with his own giving him access to one layer of
55-- encryption and thus the real public key of the sender. TODO:
56-- Counter-measures.
57--
58-- Unlike toxcore, we don't currently reserve paths for only-searching or
59-- only-announcing. Instead, we maintain 12 multi-purpose routes.
60data OnionRouter = OnionRouter
61 { -- | For every query, we remember the destination and source keys
62 -- so we can decrypt the response.
63 pendingQueries :: TVar (Word64Map PendingQuery)
64 -- | The current 12 routes that may be assigned to outgoing packets.
65 , routeMap :: TArray Int (Maybe RouteRecord)
66 -- | A set of nodes used to query for random route nodes. These aren't
67 -- used directly in onion routes, they are queried for route nodes that
68 -- are nearby randomly selected ids.
69 , trampolinesUDP :: TrampolineSet NodeInfo
70 -- | A set for TCP relays to use as trampolines when UDP is not available.
71 , trampolinesTCP :: TrampolineSet TCP.NodeInfo
72 -- | True when we need to rely on TCP relays because UDP is apparently unavailable.
73 , tcpMode :: TVar (Maybe Bool) -- Nothing: tcp disabled, False: use trampolinesUDP, True: use trampolinesTCP
74 -- | The pseudo-random generator used to select onion routes.
75 , onionDRG :: TVar ChaChaDRG
76 -- | Building onion routes happens in a dedicated thread. See 'forkRouteBuilder'.
77 , routeThread :: ThreadId
78 -- | Each of the 12 routes has a version number here that is set larger
79 -- than the 'routeVersion' set in 'routeMap' when the route should be
80 -- discarded and replaced with a fresh one.
81 , pendingRoutes :: TArray Int Int
82 -- | Parameters used to implement Kademlia for TCP relays.
83 , tcpKademliaClient :: TCP.TCPClient String Nonce8
84 -- | This thread maintains the TCP relay table.
85 , tcpKademliaThread :: ThreadId
86 , tcpProberState :: TCPCache (SessionProtocol TCP.RelayPacket TCP.RelayPacket)
87 , tcpProber :: TCP.TCPProber
88 , tcpProberThread :: ThreadId
89 -- | Kademlia table of TCP relays.
90 , tcpBucketRefresher :: BucketRefresher NodeId TCP.NodeInfo
91 -- | Debug prints are written to this channel which is then flushed to
92 -- 'routeLogger'.
93 , routeLog :: TChan String
94 -- | User supplied log function.
95 , routeLogger :: String -> IO ()
96 }
97
98data PendingQuery = PendingQuery
99 { pendingVersion :: !Int -- ^ Remembered version number so timeouts can signal a rebuild.
100 , pendingDestination :: OnionDestination RouteId
101 }
102 deriving Show
103
104data RouteRecord = RouteRecord
105 { storedRoute :: OnionRoute
106 , responseCount :: !Int
107 , timeoutCount :: !Int
108 , routeVersion :: !Int
109 , routeBirthTime :: !POSIXTime
110 }
111 deriving Show
112
113-- Onion paths have different timeouts depending on whether the path is
114-- confirmed or unconfirmed. Unconfirmed paths (paths that core has never
115-- received any responses from) have a timeout of 4 seconds with 2 tries before
116-- they are deemed non working. This is because, due to network conditions,
117-- there may be a large number of newly created paths that do not work and so
118-- trying them a lot would make finding a working path take much longer. The
119-- timeout for a confirmed path (from which a response was received) is 12
120-- seconds with 4 tries without a response. A confirmed path has a maximum
121-- lifetime of 1200 seconds to make possible deanonimization attacks more
122-- difficult.
123timeoutForRoute :: RouteRecord -> Int
124timeoutForRoute RouteRecord{ responseCount = 0 } = 4000000
125timeoutForRoute RouteRecord{ responseCount = _ } = 12000000
126
127freshRoute :: POSIXTime -> OnionRoute -> Maybe RouteRecord -> Maybe RouteRecord
128freshRoute birthday r mrec = Just $ RouteRecord
129 { storedRoute = r
130 , responseCount = 0
131 , timeoutCount = 0
132 , routeVersion = maybe 0 succ $ routeVersion <$> mrec
133 , routeBirthTime = birthday
134 }
135
136modifyArray :: TArray Int r -> (r -> r) -> Int -> STM ()
137modifyArray a f i = do
138 mx <- readArray a i
139 writeArray a i $ f mx
140{-# INLINE modifyArray #-}
141
142gotResponse :: RouteRecord -> RouteRecord
143gotResponse rr = rr
144 { responseCount = succ $ responseCount rr
145 , timeoutCount = 0
146 }
147
148gotTimeout :: RouteRecord -> RouteRecord
149gotTimeout rr = rr
150 { timeoutCount = succ $ timeoutCount rr
151 }
152
153newtype RouteEvent = BuildRoute RouteId
154
155newOnionRouter :: TransportCrypto
156 -> (String -> IO ())
157 -> Bool -- is tcp enabled?
158 -> IO ( OnionRouter
159 , TVar ( ChaChaDRG
160 , Word64Map (Either (Maybe (Bool,TCP.RelayPacket) -> IO ())
161 (Maybe (OnionMessage Identity) -> IO ()))))
162newOnionRouter crypto perror tcp_enabled = do
163 drg0 <- drgNew
164 (rlog,pq,rm) <- atomically $ do
165 rlog <- newTChan
166 pq <- newTVar W64.empty
167 rm <- newArray (0,11) Nothing
168 return (rlog,pq,rm)
169 ((tbl,(tcptbl,tcpcons)),tcp) <- do
170 (tcptbl, client) <- TCP.newClient crypto Left $ \case
171 Left v -> void . v . Just . (,) False
172 Right v -> \case
173 TCP.OnionPacketResponse x@(OnionAnnounceResponse n8 n24 _) -> do
174 mod <- lookupSender' pq rlog localhost4 n8
175 perror $ "TCP announce response from " ++ show mod
176 forM_ mod $ \od -> do
177 Onion.decrypt crypto x od >>= \case
178 Right (y,_) -> do perror $ "decrypted announce response, sending " ++ show y
179 let
180 RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
181 $ onionRouteSpec od
182 Nonce8 w8 = n8
183 atomically $ do
184 modifyTVar' pq (W64.delete w8)
185 modifyArray rm (fmap gotResponse) rid
186 void $ v $ Just y
187 _ -> return ()
188 x -> perror $ "Unexpected TCP query result: " ++ show x
189
190 let addr = SockAddrInet 0 0
191 tentative_udp = NodeInfo
192 { nodeId = key2id $ transportPublic crypto
193 , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr)
194 , nodePort = fromMaybe 0 $ sockAddrPort addr
195 }
196 tentative_info = TCP.NodeInfo tentative_udp (fromIntegral 443)
197 tbl <- atomically $ newTVar
198 $ R.nullTable (comparing TCP.nodeId)
199 (\s -> hashWithSalt s . TCP.nodeId)
200 tentative_info
201 R.defaultBucketCount
202 return $ (,) (tbl,tcptbl) TCP.TCPClient
203 { tcpCrypto = crypto
204 , tcpClient = client
205 , tcpGetGateway = \ni -> do
206 gw <- selectGateway tbl ni
207 writeTChan rlog $ unwords ["Selected TCP Gateway:",show ni,"via",show gw]
208 return gw
209 }
210 or <- atomically $ do
211 -- chan <- newTChan
212 drg <- newTVar drg0
213 -- forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
214 tn <- newTVar IntMap.empty
215 ti <- newTVar HashMap.empty
216 tc <- newTVar 0
217 ttn <- newTVar IntMap.empty
218 tti <- newTVar HashMap.empty
219 ttc <- newTVar 0
220 pr <- newArray (0,11) 0
221 prober <- TCP.newProber
222 refresher <- newBucketRefresher
223 tbl
224 (TCP.nodeSearch prober tcp)
225 (fmap (maybe False $ const True) . TCP.tcpPing (TCP.tcpClient tcp))
226 tcpmode <- newTVar $ if tcp_enabled then Just True else Nothing
227 let o = OnionRouter
228 { pendingRoutes = pr
229 , onionDRG = drg
230 , pendingQueries = pq
231 , routeMap = rm
232 , trampolinesUDP = TrampolineSet
233 { setNodes = tn
234 , setCount = tc
235 , setNodeClass = nodeClass
236 , setIDs = ti
237 }
238 , trampolinesTCP = TrampolineSet
239 { setNodes = ttn
240 , setCount = ttc
241 , setNodeClass = nodeClass . TCP.udpNodeInfo
242 , setIDs = tti
243 }
244 , tcpMode = tcpmode
245 , tcpKademliaClient = tcp
246 { TCP.tcpClient =
247 let c = TCP.tcpClient tcp
248 in c { clientNet = addHandler perror (handleMessage c)
249 $ onInbound (updateTCP o)
250 $ clientNet c }
251 }
252 , tcpBucketRefresher = refresher
253 , routeLog = rlog
254 , routeThread = error "forkRouteBuilder not invoked (missing onion route builder thread)."
255 , tcpKademliaThread = error "forkRouteBuilder not invoked (missing TCP bucket maintenance thread)."
256 , tcpProberState = tcpcons
257 , tcpProber = prober
258 , tcpProberThread = error "forkRouteBuilder not invoked (missing TCP probe thread)."
259 , routeLogger = perror
260 }
261 return o
262 return (or,tcptbl)
263
264updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO ()
265updateTCP or addr x =
266 let refresher = tcpBucketRefresher or
267 kademlia0 = refreshKademlia refresher
268 kademlia = kademlia0 { kademIO = (kademIO kademlia0)
269 { tblTransition = \tr -> do
270 case refresher of
271 BucketRefresher { refreshSearch = sch } -> do
272 let spc = searchSpace sch
273 bkts = refreshBuckets refresher
274 hookBucketList spc bkts or (trampolinesTCP or) tr
275 tblTransition (kademIO kademlia0) tr
276 }
277 }
278 in insertNode kademlia addr
279
280selectGateway :: TVar (R.BucketList TCP.NodeInfo) -> NodeInfo -> STM (Maybe TCP.NodeInfo)
281selectGateway tbl ni = do
282 ns <- kclosest TCP.tcpSpace 2 (nodeId ni) <$> readTVar tbl
283 return $ listToMaybe ns -- $ dropWhile (\n -> TCP.nodeId n == nodeId ni) ns
284
285quitRouteBuilder :: OnionRouter -> IO ()
286quitRouteBuilder or = do
287 killThread (routeThread or)
288 killThread (tcpKademliaThread or)
289 killThread (tcpProberThread or)
290
291forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> IO OnionRouter
292forkRouteBuilder or getnodes = do
293 bktsThread <- forkPollForRefresh $ tcpBucketRefresher or
294 tcpprobe <- forkIO $ TCP.runProbeQueue (tcpProber or)
295 (TCP.tcpClient $ tcpKademliaClient or)
296 12
297 labelThread tcpprobe "tcp-probe"
298 tid <- forkIO $ do
299 me <- myThreadId
300 labelThread me "OnionRouter"
301 forever $ do
302 let checkRebuild :: Int -> Int -> STM RouteEvent
303 checkRebuild rid wanted_ver = do
304 current_ver <- fmap routeVersion <$> readArray (routeMap or) rid
305 writeTChan (routeLog or) $ "ONION checkRebuild "++show(current_ver,wanted_ver)
306 check $ maybe True (< wanted_ver) current_ver
307 return $ BuildRoute $ RouteId rid
308 io <- atomically $ {-# SCC "forkRouteBuilder.log" #-}
309 (readTChan (routeLog or) >>= return . routeLogger or)
310 `orElse` {-# SCC "forkRouteBuilder.checkRebuild" #-}
311 (let stms = map (\rid -> checkRebuild rid =<< readArray (pendingRoutes or) rid)
312 [0..11]
313 in do event <- foldr1 orElse stms
314 return $ handleEvent getnodes or { routeThread = me } event)
315 io
316 return or { routeThread = tid
317 , tcpKademliaThread = bktsThread
318 , tcpProberThread = tcpprobe }
319
320generateNodeId :: MonadRandom m => m NodeId
321generateNodeId = either (error "unable to make random nodeid")
322 id
323 . S.decode <$> getRandomBytes 32
324
325distinct3by :: Eq t => (a -> t) -> a -> a -> a -> Bool
326distinct3by f a b c = f a /= f b && f b /= f c && f c /= f a
327
328-- The two integer functions below take an [inclusive,inclusive] range.
329randomR :: (DRG g, Integral a) => (a, a) -> g -> (a, g)
330randomR (l,h) = randomIvalInteger (toInteger l, toInteger h)
331
332next :: DRG g => g -> (Int,g)
333next g = withDRG g $ do bs <- getRandomBytes $ if fitsInInt (Proxy :: Proxy Word64)
334 then 8
335 else 4
336 either (return . error) return $ S.decode bs
337
338randomIvalInteger :: (DRG g, Num a) => (Integer, Integer) -> g -> (a, g)
339randomIvalInteger (l,h) rng
340 | l > h = randomIvalInteger (h,l) rng
341 | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
342 where
343 (genlo, genhi) = (minBound :: Int, maxBound :: Int) -- genRange :: RandomGen g => g -> (Int, Int)
344 b = fromIntegral genhi - fromIntegral genlo + 1
345
346 -- Probabilities of the most likely and least likely result
347 -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen
348 -- is uniform, of course
349
350 -- On average, log q / log b more random values will be generated
351 -- than the minimum
352 q = 1000
353 k = h - l + 1
354 magtgt = k * q
355
356 -- generate random values until we exceed the target magnitude
357 f mag v g | mag >= magtgt = (v, g)
358 | otherwise = v' `seq`f (mag*b) v' g' where
359 (x,g') = next g -- next :: RandomGen g => g -> (Int, g)
360 v' = (v * b + (fromIntegral x - fromIntegral genlo))
361
362-- Repeatedly attempt to select 3 nodes as a secure onion route letting 1 second
363-- elapse between retries.
364--
365-- Only the DRG random seed is updated. Hopefully another thread will change the
366-- trampolineNodes set so that selection can succeed.
367selectTrampolines :: OnionRouter -> IO (Either [TCP.NodeInfo] [NodeInfo])
368selectTrampolines or = do
369 myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
370 let tset :: (forall x. TrampolineSet x -> STM (Either [x] [x]))
371 -> STM (Either (Either [TCP.NodeInfo] [NodeInfo])
372 (Either [TCP.NodeInfo] [NodeInfo]))
373 tset f = do
374 mm <- readTVar (tcpMode or)
375 -- TODO: better logic for deciding to use TCP or UDP trampolines.
376 if fromMaybe False mm
377 then left Left . right Left <$> f (trampolinesTCP or)
378 else left Right . right Right <$> f (trampolinesUDP or)
379 atomically (tset $ internalSelectTrampolines (onionDRG or)) >>= \case
380 Left ns -> do
381 -- atomically $ writeTChan (routeLog or)
382 routeLogger or $ unwords
383 ( "ONION Discarding insecure trampolines:" : (either (map show) (map show) ns))
384 myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines.sleep")
385 case ns of
386 Left [_,_,_] -> threadDelay 1000000 -- (tcp) wait 1 second if we failed the distinct3by predicate.
387 Right [_,_,_] -> threadDelay 1000000 -- (udp) wait 1 second if we failed the distinct3by predicate.
388 _ -> threadDelay 5000000 -- wait 5 seconds if insufficient nodes.
389 myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
390 selectTrampolines or
391 Right ns -> do
392 myThreadId >>= flip labelThread ("OnionRouter")
393 return ns
394
395data TrampolineSet ni = TrampolineSet
396 { -- | A set of nodes used to query for random route nodes. These aren't
397 -- used directly in onion routes, they are queried for route nodes that
398 -- are nearby randomly selected ids.
399 --
400 -- These nodes are chosen from the kademlia buckets and when one of them
401 -- is evicted from a bucket, it is no longer used as a trampoline node.
402 setNodes :: TVar (IntMap ni)
403 -- | Indicates the current size of 'setNodes'.
404 , setCount :: TVar Int
405 -- | In order to reduce the likelihood that an attacker will control all
406 -- nodes in a route, we color the nodes with 'IPClass' and require
407 -- distinct colors for each of the hops.
408 , setNodeClass :: ni -> IPClass
409 -- | This map associates 'NodeId' values with the corresponding
410 -- 'trampolineNodes' index.
411 , setIDs :: TVar (HashMap NodeId Int)
412 }
413
414choose3 :: (Integral a, DRG drg) => drg -> a -> ([a], drg)
415choose3 drg0 cnt = ([a,b,c], drg)
416 where
417 (a, drg1) = randomR (0,cnt - 1) drg0
418 (b0, drg2) = randomR (0,cnt - 2) drg1
419 (c0, drg ) = randomR (0,cnt - 3) drg2
420 b | b0 < a = b0
421 | otherwise = b0 + 1
422 [ac,bc] = sort [a,b]
423 c1 | c0 < ac = c0
424 | otherwise = c0 + 1
425 c | c1 < bc = c1
426 | otherwise = c1 + 1
427
428-- Select 3 indices into the trampolineNodes set and returns the associated
429-- nodes provided they are suitable for use in an onion route. Otherwise, it
430-- returns Left with the nodes that were selected.
431--
432-- The only write this function does to STM state is that the onionDRG random
433-- seed will be updated.
434internalSelectTrampolines :: TVar ChaChaDRG -> TrampolineSet ni -> STM (Either [ni] [ni])
435internalSelectTrampolines setDRG TrampolineSet{..} = do
436 cnt <- readTVar setCount
437 ts <- readTVar setNodes
438 drg0 <- readTVar setDRG
439 let ([a,b,c],drg) = choose3 drg0 cnt
440 ns = mapMaybe (\n -> IntMap.lookup n ts) [a,b,c]
441 ns' <- case ns of
442 [an,bn,cn] | distinct3by setNodeClass an bn cn
443 -> return $ Right ns
444 _ -> return $ Left ns
445 writeTVar setDRG drg
446 return ns'
447
448handleEvent :: (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> OnionRouter -> RouteEvent -> IO ()
449handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
450 routeLogger or $ "ONION Rebuilding RouteId " ++ show rid
451 mb <- do
452 mts <- selectTrampolines or
453 join . atomically $ do
454 drg <- readTVar (onionDRG or)
455 av <- newTVar Nothing
456 bv <- newTVar Nothing
457 cv <- newTVar Nothing
458 let (getr, drg') = withDRG drg $ do
459 asec <- generateSecretKey -- Three aliases
460 bsec <- generateSecretKey
461 csec <- generateSecretKey
462 aq <- generateNodeId -- Three queries
463 bq <- generateNodeId
464 cq <- generateNodeId
465 sel <- B.head <$> getRandomBytes 1 -- Three two-bit result selectors (6 bits)
466 let asel = sel .&. 0x3
467 bsel = shiftR sel 2 .&. 0x3
468 csel = shiftR sel 4 .&. 0x3
469 cycle' [] = []
470 cycle' ns = cycle ns
471 sendq :: Word8 -> NodeId -> Int -> IO (Maybe NodeInfo)
472 sendq s q ni
473 | Right ts <- mts = (>>= (listToMaybe . drop (fromIntegral s) . cycle')) <$> getnodes q (ts !! ni)
474 | Left ts <- mts = case ni of
475 0 -> return $ Just $ TCP.udpNodeInfo (ts !! 0)
476 n -> (>>= (listToMaybe . drop (fromIntegral s) . (\(ns,_,_)->cycle' ns)))
477 <$> TCP.getUDPNodes (tcpKademliaClient or) q (TCP.udpNodeInfo $ ts !! n)
478 sendqs = do
479 forkLabeled "sendq.asel" $ sendq asel aq 0 >>= atomically . writeTVar av . Just
480 forkLabeled "sendq.bsel" $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just
481 forkLabeled "sendq.csel" $ sendq csel cq 2 >>= atomically . writeTVar cv . Just
482 -- This timeout should be unnecessary... But I'm paranoid.
483 -- Note: 10 seconds should be sufficient for typical get-nodes queries.
484 tm <- timeout 30000000 $ atomically $ do -- Wait for all 3 results.
485 rs <- catMaybes <$> sequence [readTVar av,readTVar bv,readTVar cv]
486 case rs of [_,_,_] -> do
487 return $ catMaybes $ rs
488 -- self <- IntMap.lookup (-1) <$> readTVar (trampolineNodes or)
489 -- return $ maybe (catMaybes rs) (\x -> [x,x,x]) self
490 _ -> retry
491 maybe (routeLogger or "ONION: Unexpected sendq timeout!" >> return [])
492 return
493 tm
494 return $ do
495 myThreadId >>= flip labelThread ("OnionRouter.sendqs")
496 let mtcpport = either (Just . TCP.tcpPort . head) (const Nothing) mts
497 nodes <- case mts of
498 Right [_,_,_] -> sendqs
499 Left [_,_,_] -> sendqs
500 _ -> return []
501 myThreadId >>= flip labelThread ("OnionRouter")
502 routeLogger or $ unlines
503 [ "ONION trampolines: " ++ show mts
504 , "ONION query results: " ++ show nodes ]
505 case nodes of
506 [a,b,c] | distinct3by nodeClass a b c -> do
507 atomically $ do
508 writeTChan (routeLog or) $ unwords [ "ONION using route:"
509 , show $ nodeAddr a
510 , show $ nodeAddr b
511 , show $ nodeAddr c ]
512 return $ Just OnionRoute
513 { routeAliasA = asec
514 , routeAliasB = bsec
515 , routeAliasC = csec
516 , routeNodeA = a
517 , routeNodeB = b
518 , routeNodeC = c
519 , routeRelayPort = mtcpport
520 }
521 [a,b,c] -> do
522 atomically $ writeTChan (routeLog or)
523 $ unwords [ "ONION Discarding insecure route:"
524 , show $ nodeAddr a
525 , show $ nodeAddr b
526 , show $ nodeAddr c
527 ]
528 return Nothing
529 _ -> return Nothing
530 writeTVar (onionDRG or) drg'
531 return $ getr
532 now <- getPOSIXTime
533 atomically $ maybe (return ()) -- writeTVar (pendingRoutes or IntMap.! rid) True)
534 (\r -> do modifyArray (routeMap or)
535 (freshRoute now r)
536 rid
537 v <- routeVersion . fromJust <$> readArray (routeMap or) rid
538 writeArray (pendingRoutes or) rid v
539 )
540 (mb :: Maybe OnionRoute)
541 case mb of
542 Just _ -> routeLogger or $ "ONION Finished RouteId " ++ show rid
543 Nothing -> routeLogger or $ "ONION Failed RouteId " ++ show rid
544
545
546lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId))
547lookupSender or = lookupSender' (pendingQueries or) (routeLog or)
548
549lookupSender' :: TVar (Word64Map PendingQuery)
550 -> TChan String
551 -> SockAddr
552 -> Nonce8
553 -> IO (Maybe (OnionDestination RouteId))
554lookupSender' pending log saddr (Nonce8 w8) = do
555 result <- atomically $ do
556 ks <- readTVar pending
557 let r = W64.lookup w8 ks
558 writeTChan log $ "ONION lookupSender " ++ unwords [show w8, "->", show r]
559 return r
560 return $ do
561 od <- result
562 let nid = nodeId $ onionNodeInfo $ pendingDestination od
563 ni <- either (const Nothing) Just $ nodeInfo nid saddr
564 Just (OnionDestination (onionAliasSelector $ pendingDestination od)
565 ni
566 (Just $ routeId nid))
567
568lookupRoute :: OnionRouter -> NodeInfo -> RouteId -> IO (Maybe OnionRoute)
569lookupRoute or ni (RouteId rid) = do
570 mb <- atomically $ readArray (routeMap or) rid
571 return $ storedRoute <$> mb
572
573lookupTimeout :: OnionRouter -> OnionDestination r -> STM (OnionDestination RouteId, Int)
574lookupTimeout or (OnionDestination asel ni Nothing) = do
575 let RouteId rid = routeId (nodeId ni)
576 mrr <- readArray (routeMap or) rid
577 writeTChan (routeLog or) $ unwords ["ONION lookupTimeout " ,show rid]
578 case mrr of
579 Just rr -> return ( OnionDestination asel ni (Just $ RouteId rid), timeoutForRoute rr)
580 Nothing -> return ( OnionDestination asel ni Nothing , 0 )
581
582hookQueries :: OnionRouter -> (tid -> Nonce8)
583 -> TransactionMethods d tid (OnionDestination RouteId) x
584 -> TransactionMethods d tid (OnionDestination RouteId) x
585hookQueries or t8 tmethods = TransactionMethods
586 { dispatchRegister = \nowPlusExpiry mvar od d -> {-# SCC "hookQ.dispatchRegister" #-} do -- :: MVar x -> d -> STM (tid, d)
587 let ni = onionNodeInfo od
588 rid@(RouteId ridn) = fromMaybe (routeId (nodeId ni)) $ onionRouteSpec od
589 wanted <- {-# SCC "hookQ.wanted" #-} (readArray (pendingRoutes or) ridn)
590 mr <- {-# SCC "hookQ.mr_action" #-} (readArray (routeMap or) ridn)
591 -- Block query until a route is ready.
592 check $ fromMaybe False $ do
593 RouteRecord{routeVersion=rv} <- {-# SCC "hookQ.mr" #-} mr
594 return $ wanted <= rv
595 (tid,d') <- dispatchRegister tmethods nowPlusExpiry mvar od d
596 let Nonce8 w8 = t8 tid
597 od' = case od of
598 OnionDestination {} -> od { onionRouteSpec = Just rid }
599 OnionToOwner a b -> OnionToOwner a b -- Type cast.
600 let pq = PendingQuery { pendingDestination = od'
601 , pendingVersion = maybe 0 routeVersion mr
602 }
603 pqs <- readTVar (pendingQueries or)
604 -- check $ W64.size pqs < 20
605 modifyTVar' (pendingQueries or) (W64.insert w8 pq)
606 writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show (Just $ pendingVersion pq,w8), ":=", show ni ]
607 return (tid,d')
608 , dispatchResponse = \tid x d -> {-# SCC "hookQ.dispatchResponse" #-} do -- :: tid -> x -> d -> STM (d, IO ())
609 let Nonce8 w8 = t8 tid
610 mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
611 modifyTVar' (pendingQueries or) (W64.delete w8)
612 forM_ mb $ \pq -> do
613 let od = pendingDestination pq
614 RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
615 $ onionRouteSpec od
616 modifyArray (routeMap or) (fmap gotResponse) rid
617 writeTChan (routeLog or) $ "ONION query del " ++ show (fmap pendingVersion mb, w8)
618 dispatchResponse tmethods tid x d
619 , dispatchCancel = \tid d -> {-# SCC "hookQ.dispatchCancel" #-} do -- :: tid -> d -> STM d
620 let Nonce8 w8 = t8 tid
621 mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
622 modifyTVar' (pendingQueries or) (W64.delete w8)
623 forM_ mb $ \pq -> do
624 let od = pendingDestination pq
625 RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
626 $ onionRouteSpec od
627 mrr <- readArray (routeMap or) rid
628 forM_ mrr $ \rr -> do
629 when (routeVersion rr == pendingVersion pq) $ do
630 let expireRoute = modifyArray (pendingRoutes or) expire rid
631 expire ver | ver <= succ (pendingVersion pq) = succ (pendingVersion pq)
632 | otherwise = ver
633 modifyArray (routeMap or) (fmap gotTimeout) rid
634 case rr of
635 RouteRecord{ responseCount = 0
636 , timeoutCount = c
637 , routeVersion = v } | c >= 5 -> expireRoute
638 RouteRecord{ responseCount = 1
639 , timeoutCount = c
640 , routeVersion = v } | c >= 10 -> expireRoute
641 RouteRecord{ timeoutCount = c
642 , routeVersion = v } | c >= 20 -> expireRoute
643 _ -> return ()
644 writeTChan (routeLog or) $ "ONION query can " ++ show (fmap pendingVersion mb, w8)
645 dispatchCancel tmethods tid d
646 }
647
648
649-- hookBucketList :: KademliaSpace NodeId NodeInfo -> TVar (BucketList NodeInfo) -> OnionRouter -> RoutingTransition NodeInfo -> STM ()
650hookBucketList :: Show ni =>
651 KademliaSpace NodeId ni
652 -> TVar (BucketList ni)
653 -> OnionRouter
654 -> TrampolineSet ni
655 -> RoutingTransition ni
656 -> STM ()
657hookBucketList kademlia bkts0 or TrampolineSet{..} (RoutingTransition ni Accepted) = do
658 (s,antibias) <- do
659 drg0 <- readTVar (onionDRG or)
660 bkts <- readTVar bkts0
661 let antibias = 2 ^ bucketNumber kademlia (kademliaLocation kademlia ni) bkts
662 (s,drg) = randomR (0,antibias - 1) drg0
663 writeTVar (onionDRG or) drg
664 {-
665 do -- Store localhost as trampoline node (-1).
666 -- This is potentionally useful for testing.
667 let self = (thisNode bkts) { nodeIP = read "127.0.0.1" }
668 modifyTVar' setNodes (IntMap.insert (-1) self)
669 -}
670 return (s::Int,antibias)
671 -- debias via stochastic filter
672 when (s == 0) $ do
673 ns <- readTVar setIDs -- (trampolineIds or)
674 case HashMap.lookup (kademliaLocation kademlia ni) ns of
675 Just _ -> return ()
676 Nothing -> do
677 cnt <- readTVar setCount
678 writeTChan (routeLog or) $ "ONION trampoline Accepted " ++ unwords ["s="++show (s,antibias),show cnt, show ni]
679 modifyTVar' setIDs (HashMap.insert (kademliaLocation kademlia ni) cnt)
680 modifyTVar' setNodes (IntMap.insert cnt ni)
681 writeTVar setCount (succ cnt)
682hookBucketList kademlia _ or TrampolineSet{..} (RoutingTransition ni Stranger) = do
683 ns <- readTVar setIDs
684 case HashMap.lookup (kademliaLocation kademlia ni) ns of
685 Just n -> do writeTVar setIDs (HashMap.delete (kademliaLocation kademlia ni) ns)
686 cnt <- pred <$> readTVar setCount
687 writeTVar setCount cnt
688 case compare n cnt of
689 EQ -> modifyTVar' setNodes (IntMap.delete n)
690 LT -> do lastnode <- (IntMap.! cnt) <$> readTVar setNodes
691 modifyTVar' setNodes
692 (IntMap.insert n lastnode . IntMap.delete cnt)
693 modifyTVar' setIDs
694 (HashMap.delete (kademliaLocation kademlia ni)
695 . HashMap.insert (kademliaLocation kademlia lastnode) n)
696 GT -> writeTChan (routeLog or) $ "BUG!! Trampoline maps are out of sync."
697 writeTChan (routeLog or) $ "ONION trampoline Stranger " ++ unwords [show n,show ni]
698 Nothing -> return ()
699hookBucketList _ _ _ _ _ = return () -- ignore Applicant event.
700
701newtype IPClass = IPClass Word32
702 deriving Eq
703
704ipkey :: IPClass -> Int
705ipkey (IPClass k) = fromIntegral k
706
707nodeClass :: NodeInfo -> IPClass
708nodeClass = ipClass . nodeAddr
709
710ipClass :: SockAddr -> IPClass
711ipClass= either ipClass' ipClass' . either4or6
712
713ipClass' :: SockAddr -> IPClass
714ipClass' (SockAddrInet _ addr) = IPClass (fromBE32 addr .&. 0xFF000000)
715ipClass' (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
716ipClass' _ = IPClass 0 -- unreachable.
717
718requestTCPMode :: OnionRouter -> Maybe Bool -> IO Bool
719requestTCPMode or wanted_mode = atomically $ requestTCPModeSTM or wanted_mode
720
721requestTCPModeSTM :: OnionRouter -> Maybe Bool -> STM Bool
722requestTCPModeSTM or wanted_mode = do
723 m <- readTVar (tcpMode or)
724 case m of
725 Nothing -> return False
726 Just oldmode -> case wanted_mode of
727 Just newmode -> do
728 writeTVar (tcpMode or) (Just newmode)
729 return newmode
730 Nothing -> return oldmode
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 02:56:29 +0000