summaryrefslogtreecommitdiff
path: root/dht/src/Network/Tox/Onion/Routes.hs
blob: b20ad7dd630927e05eb7f9fe3423d99adf6d671f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE RankNTypes               #-}
module Network.Tox.Onion.Routes where

import Control.Concurrent.ThreadUtil
import Crypto.Tox
import Network.Address
import Network.Kademlia
import Network.Kademlia.Bootstrap
import Network.Kademlia.Routing as R
import Network.Kademlia.Search
import Network.QueryResponse
import Network.QueryResponse.TCP
import Network.Tox.NodeId
import Network.Tox.Onion.Transport as Onion
import Network.Tox.RelayPinger
import qualified Data.Tox.Relay as TCP
import qualified Network.Tox.TCP as TCP
import qualified TCPProber as TCP

import Control.Arrow
import Control.Concurrent.STM
import Control.Concurrent.STM.TArray
import Control.Monad
import Crypto.Random
import Data.Array.MArray
import Data.Bits
import Data.Bool
import Data.List
import qualified Data.ByteString     as B
import Data.Functor.Identity
import Data.Hashable
import qualified Data.HashMap.Strict as HashMap
         ;import Data.HashMap.Strict (HashMap)
import qualified Data.IntMap         as IntMap
         ;import Data.IntMap         (IntMap)
import Data.Maybe
import Data.Ord
import qualified Data.Serialize      as S
import Data.Time.Clock.POSIX
import Data.Typeable
import Data.Word
import qualified Data.Word64Map      as W64
         ;import Data.Word64Map      (Word64Map, fitsInInt)
import Network.Socket
import System.Endian
import System.Timeout

-- Toxcore saves a maximum of 12 paths: 6 paths are reserved for announcing
-- ourselves and 6 others are used to search for friends.
--
-- Note: This is pointless because a man-in-the-middle attack currently makes
-- it trivial to glean friend relationships: the storing node can swap the
-- published to-route key with his own giving him access to one layer of
-- encryption and thus the real public key of the sender. TODO:
-- Counter-measures.
--
-- Unlike toxcore, we don't currently reserve paths for only-searching or
-- only-announcing.  Instead, we maintain 12 multi-purpose routes.
data OnionRouter = OnionRouter
    { -- | For every query, we remember the destination and source keys
      -- so we can decrypt the response.
      pendingQueries  :: TVar (Word64Map PendingQuery)
      -- | The current 12 routes that may be assigned to outgoing packets.
    , routeMap        :: TArray Int (Maybe RouteRecord)
      -- | A set of nodes used to query for random route nodes. These aren't
      -- used directly in onion routes, they are queried for route nodes that
      -- are nearby randomly selected ids.
    , trampolinesUDP :: TrampolineSet NodeInfo
      -- | A set for TCP relays to use as trampolines when UDP is not available.
    , trampolinesTCP :: TrampolineSet TCP.NodeInfo
      -- | True when we need to rely on TCP relays because UDP is apparently unavailable.
    , tcpMode :: TVar (Maybe Bool) -- Nothing: tcp disabled, False: use trampolinesUDP, True: use trampolinesTCP
      -- | The pseudo-random generator used to select onion routes.
    , onionDRG        :: TVar ChaChaDRG
      -- | Building onion routes happens in a dedicated thread. See 'forkRouteBuilder'.
    , routeThread     :: ThreadId
      -- | Each of the 12 routes has a version number here that is set larger
      -- than the 'routeVersion' set in 'routeMap' when the route should be
      -- discarded and replaced with a fresh one.
    , pendingRoutes   :: TArray Int Int
      -- | Parameters used to implement Kademlia for TCP relays.
    , tcpKademliaClient :: TCP.TCPClient String Nonce8
      -- | This thread maintains the TCP relay table.
    , tcpKademliaThread :: ThreadId
    , tcpProberState :: TCP.RelayCache
    , tcpProber :: TCP.TCPProber
    , tcpProberThread :: ThreadId
      -- | Kademlia table of TCP relays.
    , tcpBucketRefresher :: BucketRefresher NodeId TCP.NodeInfo
    , tcpRelayPinger :: RelayPinger
      -- | Debug prints are written to this channel which is then flushed to
      -- 'routeLogger'.
    , routeLog        :: TChan String
      -- | User supplied log function.
    , routeLogger     :: String -> IO ()
    }

data PendingQuery = PendingQuery
    { pendingVersion     :: !Int -- ^ Remembered version number so timeouts can signal a rebuild.
    , pendingDestination :: OnionDestination RouteId
    }
 deriving Show

data RouteRecord = RouteRecord
    { storedRoute    :: OnionRoute
    , responseCount  :: !Int
    , timeoutCount   :: !Int
    , routeVersion   :: !Int
    , routeBirthTime :: !POSIXTime
    }
 deriving Show

-- Onion paths have different timeouts depending on whether the path is
-- confirmed or unconfirmed. Unconfirmed paths (paths that core has never
-- received any responses from) have a timeout of 4 seconds with 2 tries before
-- they are deemed non working. This is because, due to network conditions,
-- there may be a large number of newly created paths that do not work and so
-- trying them a lot would make finding a working path take much longer. The
-- timeout for a confirmed path (from which a response was received) is 12
-- seconds with 4 tries without a response. A confirmed path has a maximum
-- lifetime of 1200 seconds to make possible deanonimization attacks more
-- difficult.
timeoutForRoute :: RouteRecord -> Int
timeoutForRoute RouteRecord{ responseCount = 0 } = 4000000
timeoutForRoute RouteRecord{ responseCount = _ } = 12000000

freshRoute :: POSIXTime -> OnionRoute -> Maybe RouteRecord -> Maybe RouteRecord
freshRoute birthday r mrec = Just $ RouteRecord
    { storedRoute    = r
    , responseCount  = 0
    , timeoutCount   = 0
    , routeVersion   = maybe 0 succ $ routeVersion <$> mrec
    , routeBirthTime = birthday
    }

modifyArray :: TArray Int r -> (r -> r) -> Int -> STM ()
modifyArray a f i = do
    mx <- readArray a i
    writeArray a i $ f mx
{-# INLINE modifyArray #-}

gotResponse :: RouteRecord -> RouteRecord
gotResponse rr = rr
    { responseCount = succ $ responseCount rr
    , timeoutCount = 0
    }

gotTimeout :: RouteRecord -> RouteRecord
gotTimeout rr = rr
    { timeoutCount = succ $ timeoutCount rr
    }

newtype RouteEvent = BuildRoute RouteId

newOnionRouter :: TransportCrypto
                    -> (String -> IO ())
                    -> Bool -- is tcp enabled?
                    -> IO ( OnionRouter
                          , Transport String TCP.ViaRelay B.ByteString
                          , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
                          )
newOnionRouter crypto perror tcp_enabled = do
    drg0 <- drgNew
    (rlog,pq,rm) <- atomically $ do
        rlog <- newTChan
        pq <- newTVar W64.empty
        rm <- newArray (0,11) Nothing
        return (rlog,pq,rm)
    ((tbl,(tcptbl,tcpcons,relaynet,onionnet)),tcp) <- do
        (tcptbl, client) <- TCP.newClient crypto
                                    id
                                    (. (Just . (,) False))
                                    (lookupSender' pq rlog)
                                    (\_ (RouteId rid) -> atomically $ fmap storedRoute <$> readArray rm rid)

        let addr = SockAddrInet 0 0
            tentative_udp = NodeInfo
                { nodeId   = key2id $ transportPublic crypto
                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
                , nodePort = fromMaybe 0 $ sockAddrPort addr
                }
            tentative_info = TCP.NodeInfo tentative_udp (fromIntegral 443)
        tbl <- atomically $ newTVar
                          $ R.nullTable (comparing TCP.nodeId)
                                        (\s -> hashWithSalt s . TCP.nodeId)
                                        tentative_info
                                        R.defaultBucketCount
        return $ (,) (tbl,tcptbl) TCP.TCPClient
            { tcpCrypto     = crypto
            , tcpClient     = client
            , tcpGetGateway = \ni -> do
                gw <- selectGateway tbl ni
                writeTChan rlog $ unwords ["Selected TCP Gateway:",show ni,"via",show gw]
                return gw
            }

    or0 <- atomically $ do
        -- chan <- newTChan
        drg <- newTVar drg0
        -- forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
        tn <- newTVar IntMap.empty
        ti <- newTVar HashMap.empty
        tc <- newTVar 0
        ttn <- newTVar IntMap.empty
        tti <- newTVar HashMap.empty
        ttc <- newTVar 0
        pr <- newArray (0,11) 0
        prober <- TCP.newProber
        refresher <- newBucketRefresher
                            tbl
                            (TCP.nodeSearch prober tcp)
                            (fmap (maybe False $ const True) . TCP.tcpPing (TCP.tcpClient tcp))
        tcpmode <- newTVar $ if tcp_enabled then Just True else Nothing
        let o = OnionRouter
                { pendingRoutes  = pr
                , onionDRG       = drg
                , pendingQueries = pq
                , routeMap       = rm
                , trampolinesUDP = TrampolineSet
                    { setNodes     = tn
                    , setCount     = tc
                    , setNodeClass = nodeClass
                    , setIDs       = ti
                    }
                , trampolinesTCP = TrampolineSet
                    { setNodes     = ttn
                    , setCount     = ttc
                    , setNodeClass = nodeClass . TCP.udpNodeInfo
                    , setIDs       = tti
                    }
                , tcpMode = tcpmode
                , tcpKademliaClient = tcp
                , tcpRelayPinger     = error "forkRouteBuilder: no RelayPinger specified"
                , tcpBucketRefresher = refresher
                , routeLog           = rlog
                , routeThread        = error "forkRouteBuilder not invoked (missing onion route builder thread)."
                , tcpKademliaThread  = error "forkRouteBuilder not invoked (missing TCP bucket maintenance thread)."
                , tcpProberState     = tcpcons
                , tcpProber          = prober
                , tcpProberThread    = error "forkRouteBuilder not invoked (missing TCP probe thread)."
                , routeLogger        = perror
                }
        return o
    pinger <- forkRelayPinger (kademSpace $ refreshKademlia $ tcpBucketRefresher or0)
                              (TCP.tcpClient tcp)
    let or = or0 { tcpRelayPinger    = pinger
                 , tcpKademliaClient = tcp
                    { TCP.tcpClient =
                        let c = TCP.tcpClient tcp
                        in c { clientNet = addHandler perror (handleMessage c)
                                            $ onInbound (updateTCP or)
                                            $ clientNet c }
                    }
                 }
    return (or,relaynet,onionnet)

updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO ()
updateTCP or addr x = do
    let refresher = tcpBucketRefresher or
        kademlia0 = refreshKademlia refresher
        kademlia = kademlia0 { kademIO = (kademIO kademlia0)
                                { tblTransition = \tr -> do
                                    case refresher of
                                        BucketRefresher { refreshSearch = sch } -> do
                                            let spc = searchSpace sch
                                                bkts = refreshBuckets refresher
                                            hookBucketList spc bkts or (trampolinesTCP or) tr
                                    tblTransition (kademIO kademlia0) tr
                                }
                             }
    atomically $ bumpRelay (tcpRelayPinger or) addr
    insertNode kademlia addr

selectGateway :: TVar (R.BucketList TCP.NodeInfo) -> NodeInfo -> STM (Maybe TCP.NodeInfo)
selectGateway tbl ni = do
    ns <- kclosest TCP.tcpSpace 2 (nodeId ni) <$> readTVar tbl
    return $ listToMaybe ns -- $ dropWhile (\n -> TCP.nodeId n == nodeId ni) ns

quitRouteBuilder :: OnionRouter -> IO ()
quitRouteBuilder or = do
    killThread (routeThread or)
    killThread (tcpKademliaThread or)
    killThread (tcpProberThread or)

forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> IO OnionRouter
forkRouteBuilder or getnodes = do
    bktsThread <- forkPollForRefresh $ tcpBucketRefresher or
    tcpprobe <- forkIO $ TCP.runProbeQueue (tcpProber or)
                                           (TCP.tcpClient $ tcpKademliaClient or)
                                           12
    labelThread tcpprobe "tcp-probe"
    tid <- forkIO $ do
        me <- myThreadId
        labelThread me "OnionRouter"
        forever $ do
            let checkRebuild :: Int -> Int -> STM RouteEvent
                checkRebuild rid wanted_ver = do
                    current_ver <- fmap routeVersion <$> readArray (routeMap or) rid
                    writeTChan (routeLog or) $ "ONION checkRebuild "++show(current_ver,wanted_ver)
                    check $ maybe True (< wanted_ver) current_ver
                    return $ BuildRoute $ RouteId rid
            io <- atomically $ {-# SCC "forkRouteBuilder.log" #-}
                   (readTChan (routeLog or) >>= return . routeLogger or)
                `orElse` {-# SCC "forkRouteBuilder.checkRebuild" #-}
                   (let stms = map (\rid -> checkRebuild rid =<< readArray (pendingRoutes or) rid)
                                   [0..11]
                        in do event <- foldr1 orElse stms
                              return $ handleEvent getnodes or { routeThread = me } event)
            io
    return or { routeThread       = tid
              , tcpKademliaThread = bktsThread
              , tcpProberThread   = tcpprobe }

generateNodeId :: MonadRandom m => m NodeId
generateNodeId = either (error "unable to make random nodeid")
                        id
                 . S.decode <$> getRandomBytes 32

distinct3by :: Eq t => (a -> t) -> a -> a -> a -> Bool
distinct3by f a b c = f a /= f b && f b /= f c && f c /= f a

-- The two integer functions below take an [inclusive,inclusive] range.
randomR :: (DRG g, Integral a) => (a, a) -> g -> (a, g)
randomR (l,h) = randomIvalInteger (toInteger l, toInteger h)

next :: DRG g => g -> (Int,g)
next g = withDRG g $ do bs <- getRandomBytes $ if fitsInInt (Proxy :: Proxy Word64)
                                                then 8
                                                else 4
                        either (return . error) return $ S.decode bs

randomIvalInteger :: (DRG g, Num a) => (Integer, Integer) -> g -> (a, g)
randomIvalInteger (l,h) rng
 | l > h     = randomIvalInteger (h,l) rng
 | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
     where
       (genlo, genhi) = (minBound :: Int, maxBound :: Int) -- genRange :: RandomGen g => g -> (Int, Int)
       b = fromIntegral genhi - fromIntegral genlo + 1

       -- Probabilities of the most likely and least likely result
       -- will differ at most by a factor of (1 +- 1/q).  Assuming the RandomGen
       -- is uniform, of course

       -- On average, log q / log b more random values will be generated
       -- than the minimum
       q = 1000
       k = h - l + 1
       magtgt = k * q

       -- generate random values until we exceed the target magnitude
       f mag v g | mag >= magtgt = (v, g)
                 | otherwise = v' `seq`f (mag*b) v' g' where
                        (x,g') = next g -- next :: RandomGen g => g -> (Int, g)
                        v' = (v * b + (fromIntegral x - fromIntegral genlo))

-- Repeatedly attempt to select 3 nodes as a secure onion route letting 1 second
-- elapse between retries.
--
-- Only the DRG random seed is updated.  Hopefully another thread will change the
-- trampolineNodes set so that selection can succeed.
selectTrampolines :: OnionRouter -> IO (Either [TCP.NodeInfo] [NodeInfo])
selectTrampolines or = do
    myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
    let tset :: (forall x. TrampolineSet x -> STM (Either [x] [x]))
                -> STM (Either (Either [TCP.NodeInfo] [NodeInfo])
                               (Either [TCP.NodeInfo] [NodeInfo]))
        tset f = do
            mm <- readTVar (tcpMode or)
            -- TODO: better logic for deciding to use TCP or UDP trampolines.
            if fromMaybe False mm
                then left Left  . right Left  <$> f (trampolinesTCP or)
                else left Right . right Right <$> f (trampolinesUDP or)
    atomically (tset $ internalSelectTrampolines (onionDRG or)) >>= \case
        Left ns -> do
            -- atomically $ writeTChan (routeLog or)
            routeLogger or $ unwords
                ( "ONION Discarding insecure trampolines:" : (either (map show) (map show) ns))
            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines.sleep")
            case ns of
                Left  [_,_,_] -> threadDelay 1000000 -- (tcp) wait 1 second if we failed the distinct3by predicate.
                Right [_,_,_] -> threadDelay 1000000 -- (udp) wait 1 second if we failed the distinct3by predicate.
                _             -> threadDelay 5000000 -- wait 5 seconds if insufficient nodes.
            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
            selectTrampolines or
        Right ns -> do
            myThreadId >>= flip labelThread ("OnionRouter")
            return ns

data TrampolineSet ni = TrampolineSet
    { -- | A set of nodes used to query for random route nodes. These aren't
      -- used directly in onion routes, they are queried for route nodes that
      -- are nearby randomly selected ids.
      --
      -- These nodes are chosen from the kademlia buckets and when one of them
      -- is evicted from a bucket, it is no longer used as a trampoline node.
      setNodes     :: TVar (IntMap ni)
      -- | Indicates the current size of 'setNodes'.
    , setCount     :: TVar Int
      -- | In order to reduce the likelihood that an attacker will control all
      -- nodes in a route, we color the nodes with 'IPClass' and require
      -- distinct colors for each of the hops.
    , setNodeClass :: ni -> IPClass
      -- | This map associates 'NodeId' values with the corresponding
      -- 'trampolineNodes' index.
    , setIDs       :: TVar (HashMap NodeId Int)
    }

choose3 :: (Integral a, DRG drg) => drg -> a -> ([a], drg)
choose3 drg0 cnt = ([a,b,c], drg)
 where
        (a, drg1) = randomR (0,cnt - 1) drg0
        (b0, drg2) = randomR (0,cnt - 2) drg1
        (c0, drg ) = randomR (0,cnt - 3) drg2
        b | b0 < a    = b0
          | otherwise = b0 + 1
        [ac,bc] = sort [a,b]
        c1 | c0 < ac    = c0
           | otherwise  = c0 + 1
        c | c1 < bc   = c1
          | otherwise = c1 + 1

-- Select 3 indices into the trampolineNodes set and returns the associated
-- nodes provided they are suitable for use in an onion route.  Otherwise, it
-- returns Left with the nodes that were selected.
--
-- The only write this function does to STM state is that the onionDRG random
-- seed will be updated.
internalSelectTrampolines :: TVar ChaChaDRG -> TrampolineSet ni -> STM (Either [ni] [ni])
internalSelectTrampolines setDRG TrampolineSet{..} = do
    cnt <- readTVar setCount
    ts <- readTVar setNodes
    drg0 <- readTVar setDRG
    let ([a,b,c],drg) = choose3 drg0 cnt
        ns = mapMaybe (\n -> IntMap.lookup n ts) [a,b,c]
    ns' <- case ns of
            [an,bn,cn] | distinct3by setNodeClass an bn cn
                       -> return $ Right ns
            _          -> return $ Left ns
    writeTVar setDRG drg
    return ns'

handleEvent :: (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> OnionRouter -> RouteEvent -> IO ()
handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
    routeLogger or $ "ONION Rebuilding RouteId " ++ show rid
    mb <- do
        mts <- selectTrampolines or
        join . atomically $ do
        drg <- readTVar (onionDRG or)
        av <- newTVar Nothing
        bv <- newTVar Nothing
        cv <- newTVar Nothing
        let (getr, drg') = withDRG drg $ do
                asec <- generateSecretKey -- Three aliases
                bsec <- generateSecretKey
                csec <- generateSecretKey
                aq <- generateNodeId -- Three queries
                bq <- generateNodeId
                cq <- generateNodeId
                sel <- B.head <$> getRandomBytes 1 -- Three two-bit result selectors (6 bits)
                let asel = sel .&. 0x3
                    bsel = shiftR sel 2 .&. 0x3
                    csel = shiftR sel 4 .&. 0x3
                    cycle' [] = []
                    cycle' ns = cycle ns
                    sendq :: Word8 -> NodeId -> Int -> IO (Maybe NodeInfo)
                    sendq s q ni
                        | Right ts <- mts = (>>= (listToMaybe . drop (fromIntegral s) . cycle')) <$> getnodes q (ts !! ni)
                        | Left  ts <- mts = case ni of
                            0 -> return $ Just $ TCP.udpNodeInfo (ts !! 0)
                            n -> (>>= (listToMaybe . drop (fromIntegral s) . (\(ns,_,_)->cycle' ns)))
                                   <$> TCP.getUDPNodes (tcpKademliaClient or) q (TCP.udpNodeInfo $ ts !! n)
                    sendqs = do
                        forkLabeled "sendq.asel" $ sendq asel aq 0 >>= atomically . writeTVar av . Just
                        forkLabeled "sendq.bsel" $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just
                        forkLabeled "sendq.csel" $ sendq csel cq 2 >>= atomically . writeTVar cv . Just
                        -- This timeout should be unnecessary... But I'm paranoid.
                        -- Note: 10 seconds should be sufficient for typical get-nodes queries.
                        tm <- timeout 30000000 $ atomically $ do -- Wait for all 3 results.
                            rs <- catMaybes <$> sequence [readTVar av,readTVar bv,readTVar cv]
                            case rs of [_,_,_] -> do
                                                    return $ catMaybes $ rs
                                                    -- self <- IntMap.lookup (-1) <$> readTVar (trampolineNodes or)
                                                    -- return $ maybe (catMaybes rs) (\x -> [x,x,x]) self
                                       _       -> retry
                        maybe (routeLogger or "ONION: Unexpected sendq timeout!" >> return [])
                              return
                              tm
                return $ do
                    myThreadId >>= flip labelThread ("OnionRouter.sendqs")
                    let mtcpport = either (Just . TCP.tcpPort . head) (const Nothing) mts
                    nodes <- case mts of
                        Right [_,_,_] -> sendqs
                        Left  [_,_,_] -> sendqs
                        _             -> return []
                    myThreadId >>= flip labelThread ("OnionRouter")
                    routeLogger or $ unlines
                        [ "ONION trampolines:   " ++ show mts
                        , "ONION query results: " ++ show nodes ]
                    case nodes of
                        [a,b,c] | distinct3by nodeClass a b c -> do
                            atomically $ do
                              writeTChan (routeLog or) $ unwords [ "ONION using route:"
                                                                 , show $ nodeAddr a
                                                                 , show $ nodeAddr b
                                                                 , show $ nodeAddr c ]
                            return $ Just OnionRoute
                                { routeAliasA = asec
                                , routeAliasB = bsec
                                , routeAliasC = csec
                                , routeNodeA = a
                                , routeNodeB = b
                                , routeNodeC = c
                                , routeRelayPort = mtcpport
                                }
                        [a,b,c] -> do
                            atomically $ writeTChan (routeLog or)
                                       $ unwords [ "ONION Discarding insecure route:"
                                                 , show $ nodeAddr a
                                                 , show $ nodeAddr b
                                                 , show $ nodeAddr c
                                                 ]
                            return Nothing
                        _ -> return Nothing
        writeTVar (onionDRG or) drg'
        return $ getr
    now <- getPOSIXTime
    atomically $ maybe (return ()) -- writeTVar (pendingRoutes or IntMap.! rid) True)
                       (\r -> do modifyArray (routeMap or)
                                             (freshRoute now r)
                                             rid
                                 v <- routeVersion . fromJust <$> readArray (routeMap or) rid
                                 writeArray (pendingRoutes or) rid v
                                 )
                       (mb :: Maybe OnionRoute)
    case mb of
        Just _  -> routeLogger or $ "ONION Finished RouteId " ++ show rid
        Nothing -> routeLogger or $ "ONION Failed RouteId " ++ show rid


lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId))
lookupSender or = lookupSender' (pendingQueries or) (routeLog or)

lookupSender' :: TVar (Word64Map PendingQuery)
                       -> TChan String
                       -> SockAddr
                       -> Nonce8
                       -> IO (Maybe (OnionDestination RouteId))
lookupSender' pending log saddr (Nonce8 w8) = do
    result <- atomically $ do
        ks <- readTVar pending
        let r = W64.lookup w8 ks
        writeTChan log $ "ONION lookupSender " ++ unwords [show w8, "->", show r]
        return r
    return $ do
        od <- result
        let nid = nodeId $ onionNodeInfo $ pendingDestination od
        ni <- either (const Nothing) Just $ nodeInfo nid saddr
        Just (OnionDestination (onionAliasSelector $ pendingDestination od)
                               ni
                               (Just $ routeId nid))

lookupRoute :: OnionRouter -> NodeInfo -> RouteId -> IO (Maybe OnionRoute)
lookupRoute or ni (RouteId rid) = do
    mb <- atomically $ readArray (routeMap or) rid
    return $ storedRoute <$> mb

lookupTimeout :: OnionRouter -> OnionDestination r -> STM (OnionDestination RouteId, Int)
lookupTimeout or (OnionDestination asel ni Nothing) = do
    let RouteId rid = routeId (nodeId ni)
    mrr <- readArray (routeMap or) rid
    writeTChan (routeLog or) $ unwords ["ONION lookupTimeout " ,show rid]
    case mrr of
        Just rr -> return ( OnionDestination asel ni (Just $ RouteId rid), timeoutForRoute rr)
        Nothing -> return ( OnionDestination asel ni Nothing             , 0 )

hookQueries :: OnionRouter -> (tid -> Nonce8)
                           -> TransactionMethods d tid (OnionDestination RouteId) x
                           -> TransactionMethods d tid (OnionDestination RouteId) x
hookQueries or t8 tmethods = TransactionMethods
    { dispatchRegister = \nowPlusExpiry mvar od d -> {-# SCC "hookQ.dispatchRegister" #-} do --  :: MVar x -> d -> STM (tid, d)
        let ni = onionNodeInfo od
            rid@(RouteId ridn) = fromMaybe (routeId (nodeId ni)) $ onionRouteSpec od
        wanted <- {-# SCC "hookQ.wanted" #-} (readArray (pendingRoutes or) ridn)
        mr <- {-# SCC "hookQ.mr_action" #-} (readArray (routeMap or) ridn)
        -- Block query until a route is ready.
        check $ fromMaybe False $ do
            RouteRecord{routeVersion=rv} <- {-# SCC "hookQ.mr" #-} mr
            return $ wanted <= rv
        (tid,d') <- dispatchRegister tmethods nowPlusExpiry mvar od d
        let Nonce8 w8 = t8 tid
            od' = case od of
                OnionDestination {} -> od { onionRouteSpec = Just rid }
                OnionToOwner a b    -> OnionToOwner a b -- Type cast.
        let pq = PendingQuery { pendingDestination = od'
                              , pendingVersion = maybe 0 routeVersion mr
                              }
        pqs <- readTVar (pendingQueries or)
        -- check $ W64.size pqs < 20
        modifyTVar' (pendingQueries or) (W64.insert w8 pq)
        writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show (Just $ pendingVersion pq,w8), ":=", show ni ]
        return (tid,d')
    , dispatchResponse = \tid x d -> {-# SCC "hookQ.dispatchResponse" #-} do -- :: tid -> x -> d -> STM (d, IO ())
        let Nonce8 w8 = t8 tid
        mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
        modifyTVar' (pendingQueries or) (W64.delete w8)
        forM_ mb $ \pq -> do
            let od = pendingDestination pq
                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
                                $ onionRouteSpec od
            modifyArray (routeMap or) (fmap gotResponse) rid
        writeTChan (routeLog or) $ "ONION query del " ++ show (fmap pendingVersion mb, w8)
        dispatchResponse tmethods tid x d
    , dispatchCancel = \tid d -> {-# SCC "hookQ.dispatchCancel" #-} do -- :: tid -> d -> STM d
        let Nonce8 w8 = t8 tid
        mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
        modifyTVar' (pendingQueries or) (W64.delete w8)
        forM_ mb $ \pq -> do
            let od = pendingDestination pq
                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
                                $ onionRouteSpec od
            mrr <- readArray (routeMap or) rid
            forM_ mrr $ \rr -> do
            when (routeVersion rr == pendingVersion pq) $ do
            let expireRoute = modifyArray (pendingRoutes or) expire rid
                expire ver | ver <= succ (pendingVersion pq) = succ (pendingVersion pq)
                           | otherwise                       = ver
            modifyArray (routeMap or) (fmap gotTimeout) rid
            case rr of
                RouteRecord{ responseCount = 0
                           , timeoutCount  = c
                           , routeVersion = v } | c >= 5 -> expireRoute
                RouteRecord{ responseCount = 1
                           , timeoutCount = c
                           , routeVersion = v } | c >= 10 -> expireRoute
                RouteRecord{ timeoutCount = c
                           , routeVersion = v } | c >= 20 -> expireRoute
                _ -> return ()
        writeTChan (routeLog or) $ "ONION query can " ++ show (fmap pendingVersion mb, w8)
        dispatchCancel tmethods tid d
    }


-- hookBucketList :: KademliaSpace NodeId NodeInfo -> TVar (BucketList NodeInfo) ->  OnionRouter -> RoutingTransition NodeInfo -> STM ()
hookBucketList :: Show ni =>
                        KademliaSpace NodeId ni
                        -> TVar (BucketList ni)
                        -> OnionRouter
                        -> TrampolineSet ni
                        -> RoutingTransition ni
                        -> STM ()
hookBucketList kademlia bkts0 or TrampolineSet{..} (RoutingTransition ni Accepted) = do
    (s,antibias) <- do
        drg0 <- readTVar (onionDRG or)
        bkts <- readTVar bkts0
        let antibias = 2 ^ bucketNumber kademlia (kademliaLocation kademlia ni) bkts
            (s,drg)  = randomR (0,antibias - 1) drg0
        writeTVar (onionDRG or) drg
        {-
        do -- Store localhost as trampoline node (-1).
           -- This is potentionally useful for testing.
           let self = (thisNode bkts) { nodeIP = read "127.0.0.1" }
           modifyTVar' setNodes (IntMap.insert (-1) self)
        -}
        return (s::Int,antibias)
    -- debias via stochastic filter
    when (s == 0) $ do
    ns <- readTVar setIDs -- (trampolineIds or)
    case HashMap.lookup (kademliaLocation kademlia ni) ns of
        Just _ -> return ()
        Nothing -> do
            cnt <- readTVar setCount
            writeTChan (routeLog or) $ "ONION trampoline Accepted " ++ unwords ["s="++show (s,antibias),show cnt, show ni]
            modifyTVar' setIDs (HashMap.insert (kademliaLocation kademlia ni) cnt)
            modifyTVar' setNodes (IntMap.insert cnt ni)
            writeTVar setCount (succ cnt)
hookBucketList kademlia _ or TrampolineSet{..} (RoutingTransition ni Stranger) = do
    ns <- readTVar setIDs
    case HashMap.lookup (kademliaLocation kademlia ni) ns of
        Just n -> do writeTVar setIDs (HashMap.delete (kademliaLocation kademlia ni) ns)
                     cnt <- pred <$> readTVar setCount
                     writeTVar setCount cnt
                     case compare n cnt of
                        EQ -> modifyTVar' setNodes (IntMap.delete n)
                        LT -> do lastnode <- (IntMap.! cnt) <$> readTVar setNodes
                                 modifyTVar' setNodes
                                             (IntMap.insert n lastnode . IntMap.delete cnt)
                                 modifyTVar' setIDs
                                             (HashMap.delete (kademliaLocation kademlia ni)
                                                              . HashMap.insert (kademliaLocation kademlia lastnode) n)
                        GT -> writeTChan (routeLog or) $ "BUG!! Trampoline maps are out of sync."
                     writeTChan (routeLog or) $ "ONION trampoline Stranger " ++ unwords [show n,show ni]
        Nothing -> return ()
hookBucketList _ _ _ _ _ = return () -- ignore Applicant event.

newtype IPClass = IPClass Word32
 deriving Eq

ipkey :: IPClass -> Int
ipkey (IPClass k) = fromIntegral k

nodeClass :: NodeInfo -> IPClass
nodeClass = ipClass . nodeAddr

ipClass :: SockAddr -> IPClass
ipClass= either ipClass' ipClass' . either4or6

ipClass' :: SockAddr -> IPClass
ipClass' (SockAddrInet _ addr)                = IPClass (fromBE32 addr .&. 0xFF000000)
ipClass' (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
ipClass' _                                    = IPClass 0 -- unreachable.

requestTCPMode :: OnionRouter -> Maybe Bool -> IO Bool
requestTCPMode or wanted_mode = atomically $ requestTCPModeSTM or wanted_mode

requestTCPModeSTM :: OnionRouter -> Maybe Bool -> STM Bool
requestTCPModeSTM or wanted_mode = do
    m <- readTVar (tcpMode or)
    case m of
        Nothing -> return False
        Just oldmode -> case wanted_mode of
            Just newmode -> do
                writeTVar (tcpMode or) (Just newmode)
                return newmode
            Nothing -> return oldmode