{-# 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 Nonce8 , 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 (\x -> \qid -> x qid . Success . (,) 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 (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 -> STM (Maybe (OnionDestination RouteId)) lookupSender or saddr n8 = lookupSender' (pendingQueries or) (routeLog or) saddr n8 lookupSender' :: TVar (Word64Map PendingQuery) -> TChan String -> SockAddr -> Nonce8 -> STM (Maybe (OnionDestination RouteId)) lookupSender' pending log saddr (Nonce8 w8) = do result <- 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 resolveRouteFromNodeId :: OnionRouter -> NodeId -> IO (RouteId,Maybe OnionRoute) resolveRouteFromNodeId or nid = do let RouteId rid = routeId nid mb <- atomically $ fmap storedRoute <$> readArray (routeMap or) rid return (RouteId rid,mb) showRoute :: String -> OnionRoute -> [String] showRoute prefix r = [ prefix ++ maybe (show $ routeNodeA r) (show . TCP.NodeInfo (routeNodeA r)) (routeRelayPort r) , prefix ++ show (routeNodeB r) , prefix ++ show (routeNodeC r) ] 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 rx d -> {-# SCC "hookQ.dispatchResponse" #-} do -- :: tid -> x -> d -> STM (d, IO ()) case rx of Success x -> do 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 rx d _ -> do -- Timed out or canceled... 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 case rx of TimedOut -> do 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 () _ -> return () -- Don't penalize route for canceled queries. writeTChan (routeLog or) $ "ONION query can " ++ show (fmap pendingVersion mb, w8) dispatchResponse tmethods tid rx 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