diff options
Diffstat (limited to 'OnionRouter.hs')
-rw-r--r-- | OnionRouter.hs | 57 |
1 files changed, 44 insertions, 13 deletions
diff --git a/OnionRouter.hs b/OnionRouter.hs index bbc9ad8f..5f66dc68 100644 --- a/OnionRouter.hs +++ b/OnionRouter.hs | |||
@@ -12,7 +12,8 @@ import Network.Kademlia.Routing as R | |||
12 | import Network.Kademlia.Search | 12 | import Network.Kademlia.Search |
13 | import Network.QueryResponse | 13 | import Network.QueryResponse |
14 | import Network.Tox.NodeId | 14 | import Network.Tox.NodeId |
15 | import Network.Tox.Onion.Transport | 15 | import Network.Tox.Onion.Transport as Onion |
16 | import qualified Data.Tox.Relay as TCP | ||
16 | import qualified Network.Tox.TCP as TCP | 17 | import qualified Network.Tox.TCP as TCP |
17 | import qualified TCPProber as TCP | 18 | import qualified TCPProber as TCP |
18 | 19 | ||
@@ -26,6 +27,7 @@ import Data.Bits | |||
26 | import Data.Bool | 27 | import Data.Bool |
27 | import Data.List | 28 | import Data.List |
28 | import qualified Data.ByteString as B | 29 | import qualified Data.ByteString as B |
30 | import Data.Functor.Identity | ||
29 | import Data.Hashable | 31 | import Data.Hashable |
30 | import qualified Data.HashMap.Strict as HashMap | 32 | import qualified Data.HashMap.Strict as HashMap |
31 | ;import Data.HashMap.Strict (HashMap) | 33 | ;import Data.HashMap.Strict (HashMap) |
@@ -147,11 +149,27 @@ gotTimeout rr = rr | |||
147 | 149 | ||
148 | newtype RouteEvent = BuildRoute RouteId | 150 | newtype RouteEvent = BuildRoute RouteId |
149 | 151 | ||
150 | newOnionRouter :: TransportCrypto -> (String -> IO ()) -> IO OnionRouter | 152 | newOnionRouter :: TransportCrypto |
153 | -> (String -> IO ()) | ||
154 | -> IO ( OnionRouter | ||
155 | , TVar ( ChaChaDRG | ||
156 | , Word64Map (Either (MVar TCP.RelayPacket) | ||
157 | (MVar (OnionMessage Identity))))) | ||
151 | newOnionRouter crypto perror = do | 158 | newOnionRouter crypto perror = do |
152 | drg0 <- drgNew | 159 | drg0 <- drgNew |
153 | (tbl,tcp) <- do | 160 | (rlog,pq) <- atomically $ (,) <$> newTChan <*> newTVar W64.empty |
154 | client <- TCP.newClient crypto | 161 | ((tbl,tcptbl),tcp) <- do |
162 | (tcptbl, client) <- TCP.newClient crypto Left $ \case | ||
163 | Left v -> void . tryPutMVar v | ||
164 | Right v -> \case | ||
165 | TCP.OnionPacketResponse x@(OnionAnnounceResponse n8 n24 _) -> do | ||
166 | mod <- lookupSender' pq rlog localhost4 n8 | ||
167 | forM_ mod $ \od -> do | ||
168 | Onion.decrypt crypto x od >>= \case | ||
169 | Right (y,_) -> void $ tryPutMVar v y | ||
170 | _ -> return () | ||
171 | _ -> return () | ||
172 | |||
155 | let addr = SockAddrInet 0 0 | 173 | let addr = SockAddrInet 0 0 |
156 | tentative_udp = NodeInfo | 174 | tentative_udp = NodeInfo |
157 | { nodeId = key2id $ transportPublic crypto | 175 | { nodeId = key2id $ transportPublic crypto |
@@ -164,7 +182,7 @@ newOnionRouter crypto perror = do | |||
164 | (\s -> hashWithSalt s . TCP.nodeId) | 182 | (\s -> hashWithSalt s . TCP.nodeId) |
165 | tentative_info | 183 | tentative_info |
166 | R.defaultBucketCount | 184 | R.defaultBucketCount |
167 | return $ (,) tbl TCP.TCPClient | 185 | return $ (,) (tbl,tcptbl) TCP.TCPClient |
168 | { tcpCrypto = crypto | 186 | { tcpCrypto = crypto |
169 | , tcpClient = client | 187 | , tcpClient = client |
170 | , tcpGetGateway = selectGateway tbl | 188 | , tcpGetGateway = selectGateway tbl |
@@ -173,7 +191,6 @@ newOnionRouter crypto perror = do | |||
173 | -- chan <- newTChan | 191 | -- chan <- newTChan |
174 | drg <- newTVar drg0 | 192 | drg <- newTVar drg0 |
175 | -- forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n) | 193 | -- forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n) |
176 | pq <- newTVar W64.empty | ||
177 | rm <- newArray (0,11) Nothing | 194 | rm <- newArray (0,11) Nothing |
178 | tn <- newTVar IntMap.empty | 195 | tn <- newTVar IntMap.empty |
179 | ti <- newTVar HashMap.empty | 196 | ti <- newTVar HashMap.empty |
@@ -182,7 +199,6 @@ newOnionRouter crypto perror = do | |||
182 | tti <- newTVar HashMap.empty | 199 | tti <- newTVar HashMap.empty |
183 | ttc <- newTVar 0 | 200 | ttc <- newTVar 0 |
184 | pr <- newArray (0,11) 0 | 201 | pr <- newArray (0,11) 0 |
185 | rlog <- newTChan | ||
186 | prober <- TCP.newProber | 202 | prober <- TCP.newProber |
187 | refresher <- newBucketRefresher | 203 | refresher <- newBucketRefresher |
188 | tbl | 204 | tbl |
@@ -223,7 +239,7 @@ newOnionRouter crypto perror = do | |||
223 | , routeLogger = perror | 239 | , routeLogger = perror |
224 | } | 240 | } |
225 | return o | 241 | return o |
226 | return or | 242 | return (or,tcptbl) |
227 | 243 | ||
228 | updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO () | 244 | updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO () |
229 | updateTCP or addr x = | 245 | updateTCP or addr x = |
@@ -448,6 +464,7 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do | |||
448 | return $ do | 464 | return $ do |
449 | myThreadId >>= flip labelThread ("OnionRouter.sendqs") | 465 | myThreadId >>= flip labelThread ("OnionRouter.sendqs") |
450 | let Right ts = mts | 466 | let Right ts = mts |
467 | mtcpport = Nothing -- TODO | ||
451 | nodes <- case ts of | 468 | nodes <- case ts of |
452 | [_,_,_] -> sendqs | 469 | [_,_,_] -> sendqs |
453 | _ -> return [] | 470 | _ -> return [] |
@@ -469,9 +486,15 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do | |||
469 | , routeNodeA = a | 486 | , routeNodeA = a |
470 | , routeNodeB = b | 487 | , routeNodeB = b |
471 | , routeNodeC = c | 488 | , routeNodeC = c |
489 | , routeRelayPort = mtcpport | ||
472 | } | 490 | } |
473 | [a,b,c] -> do | 491 | [a,b,c] -> do |
474 | atomically $ writeTChan (routeLog or) $ unwords [ "ONION Discarding insecure route:", show $ nodeAddr a, show $ nodeAddr b, show $ nodeAddr c] | 492 | atomically $ writeTChan (routeLog or) |
493 | $ unwords [ "ONION Discarding insecure route:" | ||
494 | , show $ nodeAddr a | ||
495 | , show $ nodeAddr b | ||
496 | , show $ nodeAddr c | ||
497 | ] | ||
475 | return Nothing | 498 | return Nothing |
476 | _ -> return Nothing | 499 | _ -> return Nothing |
477 | writeTVar (onionDRG or) drg' | 500 | writeTVar (onionDRG or) drg' |
@@ -484,17 +507,25 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do | |||
484 | v <- routeVersion . fromJust <$> readArray (routeMap or) rid | 507 | v <- routeVersion . fromJust <$> readArray (routeMap or) rid |
485 | writeArray (pendingRoutes or) rid v | 508 | writeArray (pendingRoutes or) rid v |
486 | ) | 509 | ) |
487 | mb | 510 | (mb :: Maybe OnionRoute) |
488 | case mb of | 511 | case mb of |
489 | Just _ -> routeLogger or $ "ONION Finished RouteId " ++ show rid | 512 | Just _ -> routeLogger or $ "ONION Finished RouteId " ++ show rid |
490 | Nothing -> routeLogger or $ "ONION Failed RouteId " ++ show rid | 513 | Nothing -> routeLogger or $ "ONION Failed RouteId " ++ show rid |
491 | 514 | ||
515 | |||
492 | lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId)) | 516 | lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId)) |
493 | lookupSender or saddr (Nonce8 w8) = do | 517 | lookupSender or = lookupSender' (pendingQueries or) (routeLog or) |
518 | |||
519 | lookupSender' :: TVar (Word64Map PendingQuery) | ||
520 | -> TChan String | ||
521 | -> SockAddr | ||
522 | -> Nonce8 | ||
523 | -> IO (Maybe (OnionDestination RouteId)) | ||
524 | lookupSender' pending log saddr (Nonce8 w8) = do | ||
494 | result <- atomically $ do | 525 | result <- atomically $ do |
495 | ks <- readTVar (pendingQueries or) | 526 | ks <- readTVar pending |
496 | let r = W64.lookup w8 ks | 527 | let r = W64.lookup w8 ks |
497 | writeTChan (routeLog or) $ "ONION lookupSender " ++ unwords [show w8, "->", show r] | 528 | writeTChan log $ "ONION lookupSender " ++ unwords [show w8, "->", show r] |
498 | return r | 529 | return r |
499 | return $ do | 530 | return $ do |
500 | od <- result | 531 | od <- result |