Fixed onion routes for IPv4-mapped IPv6 addresses.

1 files changed, 50 insertions, 17 deletions

diff --git a/OnionRouter.hs b/OnionRouter.hs
index 26bc6525..eb79b70b 100644
--- a/OnionRouter.hs
+++ b/OnionRouter.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE LambdaCase #-}
 module OnionRouter where
 
 import Control.Concurrent.Lifted.Instrument
 import Crypto.Tox
+import Network.Address
 import Network.Kademlia
 import Network.Kademlia.Routing
 import Network.QueryResponse
@@ -144,7 +146,7 @@ newOnionRouter = do
             }
     return or
 
-forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO [NodeInfo]) -> IO OnionRouter
+forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> IO OnionRouter
 forkRouteBuilder or getnodes = do
     tid <- forkIO $ do
         me <- myThreadId
@@ -152,7 +154,8 @@ forkRouteBuilder or getnodes = do
         forever $ do
             let checkRebuild rid want_build stm = flip orElse stm $ do
                     readTVar want_build >>= check
-                    writeTVar want_build False
+                    -- This was moved to handleEvent to allow retry on fail.
+                    -- writeTVar want_build False -- Prevent redundant BuildRoute events.
                     return $ BuildRoute $ RouteId rid
             io <- atomically $
                    (readTChan (routeLog or) >>= return . hPutStrLn stderr)
@@ -204,8 +207,24 @@ randomIvalInteger (l,h) rng
                         (x,g') = next g -- next :: RandomGen g => g -> (Int, g)
                         v' = (v * b + (fromIntegral x - fromIntegral genlo))
 
-selectTrampolines :: OnionRouter -> STM [NodeInfo]
+selectTrampolines :: OnionRouter -> IO [NodeInfo]
 selectTrampolines or = do
+    myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
+    atomically (selectTrampolines' or) >>= \case
+        Left ns -> do
+            -- atomically $ writeTChan (routeLog or)
+            hPutStrLn stderr $ unwords
+                ( "ONION Discarding insecure trampolines:" : (map (show . nodeAddr) ns) )
+            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines.sleep")
+            threadDelay 1000000
+            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
+            selectTrampolines or
+        Right ns -> do
+            myThreadId >>= flip labelThread ("OnionRouter")
+            return ns
+
+selectTrampolines' :: OnionRouter -> STM (Either [NodeInfo] [NodeInfo])
+selectTrampolines' or = do
     cnt <- readTVar (trampolineCount or)
     ts <- readTVar (trampolineNodes or)
     drg0 <- readTVar (onionDRG or)
@@ -220,17 +239,18 @@ selectTrampolines or = do
           | otherwise = c1 + 1
         ns = mapMaybe (\n -> IntMap.lookup n ts) [a,b,c]
     ns' <- case ns of
-            [an,bn,cn] -> do check $ distinct3by nodeClass an bn cn
-                             return ns
-            _          -> retry
+            [an,bn,cn] | distinct3by nodeClass an bn cn
+                       -> return $ Right ns
+            _          -> return $ Left ns
     writeTVar (onionDRG or) drg
     return ns'
 
-handleEvent :: (NodeId -> NodeInfo -> IO [NodeInfo]) -> OnionRouter -> RouteEvent -> IO ()
+handleEvent :: (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> OnionRouter -> RouteEvent -> IO ()
 handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
     hPutStrLn stderr $ "ONION Rebuilding RouteId " ++ show rid
-    mb <- join . atomically $ do
+    mb <- do
         ts <- selectTrampolines or
+        join . atomically $ do
         drg <- readTVar (onionDRG or)
         [av,bv,cv] <- sequence $ replicate 3 (newTVar Nothing)
         let (getr, drg') = withDRG drg $ do
@@ -244,7 +264,7 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
                 let asel = sel .&. 0x3
                     bsel = shiftR sel 2 .&. 0x3
                     csel = shiftR sel 4 .&. 0x3
-                    sendq s q ni = listToMaybe . drop (fromIntegral s) <$> getnodes q ni
+                    sendq s q ni = fmap (listToMaybe . drop (fromIntegral s)) <$> getnodes q ni
                     sendqs = do
                         forkIO $ sendq asel aq (ts !! 0) >>= atomically . writeTVar av . Just
                         forkIO $ sendq bsel bq (ts !! 1) >>= atomically . writeTVar bv . Just
@@ -252,18 +272,26 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
                         atomically $ do -- Wait for all 3 results.
                             rs <- catMaybes <$> sequence [readTVar av,readTVar bv,readTVar cv]
                             case rs of [_,_,_] -> do
-                                                    return $ catMaybes rs
+                                                    return $ catMaybes $ catMaybes rs
                                                     -- self <- IntMap.lookup (-1) <$> readTVar (trampolineNodes or)
                                                     -- return $ maybe (catMaybes rs) (\x -> [x,x,x]) self
                                        _       -> retry
                 return $ do
-                    nodes <- sendqs
+                    myThreadId >>= flip labelThread ("OnionRouter.sendqs")
+                    nodes <- case ts of
+                        [_,_,_] -> sendqs
+                        _       -> return []
+                    myThreadId >>= flip labelThread ("OnionRouter")
                     hPutStr stderr $ unlines
                         [ "ONION trampolines:   " ++ show ts
                         , "ONION query results: " ++ show nodes ]
                     case nodes of
                         [a,b,c] | distinct3by nodeClass a b c -> do
-                            atomically $ writeTChan (routeLog or) $ unwords [ "ONION using route:", show $ nodeAddr a, show $ nodeAddr b, show $ nodeAddr c]
+                            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
@@ -279,8 +307,10 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
         writeTVar (onionDRG or) drg'
         return $ getr
     atomically $ maybe (writeTVar (pendingRoutes or IntMap.! rid) True)
-                       (\r -> modifyTVar' (routeMap or)
-                                          (IntMap.insert rid $ freshRoute r))
+                       (\r -> do modifyTVar' (routeMap or)
+                                             (IntMap.insert rid $ freshRoute r)
+                                 writeTVar (pendingRoutes or IntMap.! rid) False
+                                 )
                        mb
     case mb of
         Just _  -> hPutStrLn stderr $ "ONION Finished RouteId " ++ show rid
@@ -405,6 +435,9 @@ nodeClass :: NodeInfo -> IPClass
 nodeClass = ipClass. nodeAddr
 
 ipClass :: SockAddr -> IPClass
-ipClass (SockAddrInet _ addr)                = IPClass (fromBE32 addr .&. 0xFF000000)
-ipClass (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
-ipClass _                                    = IPClass 0 -- unreachable.
+ipClass= either ipClass' ipClass' . either4or6
+
+ipClass' :: SockAddr -> IPClass
+ipClass' (SockAddrInet _ addr)                = IPClass (fromBE32 addr .&. 0xFF000000)
+ipClass' (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
+ipClass' _                                    = IPClass 0 -- unreachable.