Remember which version of an onion route timed out.

1 files changed, 69 insertions, 37 deletions

diff --git a/OnionRouter.hs b/OnionRouter.hs
index 428b6d8e..17cea8e8 100644
--- a/OnionRouter.hs
+++ b/OnionRouter.hs
@@ -46,10 +46,8 @@ import System.Timeout
 -- 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.  Note, the RouteId field is not
-      -- currently stored here.  It is inferred from the destination NodeId.
-      -- Instead, a 'Nothing' is stored.
-      pendingQueries  :: TVar (Word64Map (OnionDestination RouteId))
+      -- so we can decrypt the response.
+      pendingQueries  :: TVar (Word64Map PendingQuery)
       -- | The current 12 routes that may be assigned to outgoing packets.
     , routeMap        :: TVar (IntMap RouteRecord)
       -- | A set of nodes used to query for random route nodes. These aren't
@@ -71,9 +69,10 @@ data OnionRouter = OnionRouter
     , onionDRG        :: TVar ChaChaDRG
       -- | Building onion routes happens in a dedicated thread. See 'forkRouteBuilder'.
     , routeThread     :: ThreadId
-      -- | Each of the 12 routes has a flag here that is set True when the
-      -- route should be discarded and replaced with a fresh one.
-    , pendingRoutes   :: IntMap (TVar Bool)
+      -- | 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   :: IntMap (TVar Int)
       -- | Debug prints are written to this channel which is then flushed to
       -- 'routeLogger'.
     , routeLog        :: TChan String
@@ -81,10 +80,17 @@ data OnionRouter = OnionRouter
     , 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
     }
 
 -- Onion paths have different timeouts depending on whether the path is
@@ -101,11 +107,12 @@ timeoutForRoute :: RouteRecord -> Int
 timeoutForRoute RouteRecord{ responseCount = 0 } = 4000000
 timeoutForRoute RouteRecord{ responseCount = _ } = 10000000
 
-freshRoute :: OnionRoute -> RouteRecord
-freshRoute r = RouteRecord
+freshRoute :: OnionRoute -> Maybe RouteRecord -> Maybe RouteRecord
+freshRoute r mrec = Just $ RouteRecord
     { storedRoute = r
     , responseCount = 0
     , timeoutCount = 0
+    , routeVersion = maybe 0 succ $ routeVersion <$> mrec
     }
 
 gotResponse :: RouteRecord -> RouteRecord
@@ -125,15 +132,15 @@ newOnionRouter :: (String -> IO ()) -> IO OnionRouter
 newOnionRouter perror = do
     drg0 <- drgNew
     or <- atomically $ do
-        chan <- newTChan
+        -- chan <- newTChan
         drg <- newTVar drg0
-        forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
+        -- forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
         pq <- newTVar W64.empty
         rm <- newTVar IntMap.empty
         tn <- newTVar IntMap.empty
         ti <- newTVar HashMap.empty
         tc <- newTVar 0
-        vs <- sequence $ replicate 12 (newTVar True)
+        vs <- sequence $ replicate 12 (newTVar 0)
         rlog <- newTChan
         return OnionRouter
             { pendingRoutes = IntMap.fromList $ zip [0..11] vs
@@ -156,9 +163,10 @@ forkRouteBuilder or getnodes = do
         labelThread me "OnionRouter"
         forever $ do
             let checkRebuild rid want_build stm = flip orElse stm $ do
-                    readTVar want_build >>= check
-                    -- This was moved to handleEvent to allow retry on fail.
-                    -- writeTVar want_build False -- Prevent redundant BuildRoute events.
+                    wanted_ver <- readTVar want_build
+                    current_ver <- fmap routeVersion . IntMap.lookup rid <$> readTVar (routeMap or)
+                    writeTChan (routeLog or) $ "ONION checkRebuild "++show(current_ver,wanted_ver)
+                    check $ maybe True (< wanted_ver) current_ver
                     return $ BuildRoute $ RouteId rid
             io <- atomically $
                    (readTChan (routeLog or) >>= return . routeLogger or)
@@ -325,10 +333,11 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
                         _ -> return Nothing
         writeTVar (onionDRG or) drg'
         return $ getr
-    atomically $ maybe (writeTVar (pendingRoutes or IntMap.! rid) True)
+    atomically $ maybe (return ()) -- writeTVar (pendingRoutes or IntMap.! rid) True)
                        (\r -> do modifyTVar' (routeMap or)
-                                             (IntMap.insert rid $ freshRoute r)
-                                 writeTVar (pendingRoutes or IntMap.! rid) False
+                                             (IntMap.alter (freshRoute r) rid)
+                                 v <- routeVersion . (IntMap.! rid) <$> readTVar (routeMap or)
+                                 writeTVar (pendingRoutes or IntMap.! rid) v
                                  )
                        mb
     case mb of
@@ -344,9 +353,9 @@ lookupSender or saddr (Nonce8 w8) = do
         return r
     return $ do
         od <- result
-        let nid = nodeId $ onionNodeInfo od
+        let nid = nodeId $ onionNodeInfo $ pendingDestination od
         ni <- either (const Nothing) Just $ nodeInfo nid saddr
-        Just (OnionDestination (onionAliasSelector od)
+        Just (OnionDestination (onionAliasSelector $ pendingDestination od)
                                ni
                                (Just $ routeId nid))
 
@@ -365,42 +374,65 @@ lookupTimeout or n8 (OnionDestination asel ni Nothing) = do
         Nothing -> return ( OnionDestination asel ni Nothing             , 0 )
 
 hookQueries :: OnionRouter -> (tid -> Nonce8)
-                           -> TransactionMethods d tid (OnionDestination r) x
-                           -> TransactionMethods d tid (OnionDestination r) x
+                           -> TransactionMethods d tid (OnionDestination RouteId) x
+                           -> TransactionMethods d tid (OnionDestination RouteId) x
 hookQueries or t8 tmethods = TransactionMethods
     { dispatchRegister = \mvar od d -> do --  :: MVar x -> d -> STM (tid, d)
         (tid,d') <- dispatchRegister tmethods mvar od d
         let Nonce8 w8 = t8 tid
-            od' = case od of OnionDestination {} -> od { onionRouteSpec = Nothing }
-                             OnionToOwner a b    -> OnionToOwner a b -- Type cast.
             ni = onionNodeInfo od
-        modifyTVar' (pendingQueries or) (W64.insert w8 od')
-        writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show w8, ":=", show ni ]
+            rid@(RouteId ridn) = fromMaybe (routeId (nodeId ni)) $ onionRouteSpec od
+            od' = case od of
+                OnionDestination {} -> od { onionRouteSpec = Just rid }
+                OnionToOwner a b    -> OnionToOwner a b -- Type cast.
+        wanted <- readTVar (pendingRoutes or IntMap.! ridn)
+        mr <- IntMap.lookup ridn <$> readTVar (routeMap or)
+        -- Block query until a route is ready.
+        check $ fromMaybe False $ do
+            RouteRecord{routeVersion=rv} <- mr
+            return $ wanted <= rv
+        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 -> 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 $ \od -> do
-            let RouteId rid = routeId (nodeId (onionNodeInfo od))
+        forM_ mb $ \pq -> do
+            let od = pendingDestination pq
+                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
+                                $ onionRouteSpec od
             modifyTVar' (routeMap or) (IntMap.adjust gotResponse rid)
-        writeTChan (routeLog or) $ "ONION query del " ++ show w8
+        writeTChan (routeLog or) $ "ONION query del " ++ show (fmap pendingVersion mb, w8)
         dispatchResponse tmethods tid x d
     , dispatchCancel = \tid d -> 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 $ \od -> do
-            let RouteId rid = routeId (nodeId (onionNodeInfo od))
+        forM_ mb $ \pq -> do
+            let od = pendingDestination pq
+                RouteId rid = fromMaybe (routeId (nodeId (onionNodeInfo od)))
+                                $ onionRouteSpec od
+            mrr <- IntMap.lookup rid <$> readTVar (routeMap or)
+            forM_ mrr $ \rr -> do
+            when (routeVersion rr == pendingVersion pq) $ do
+            let expireRoute = modifyTVar' (pendingRoutes or IntMap.! rid) expire
+                expire ver | ver <= succ (pendingVersion pq) = succ (pendingVersion pq)
+                           | otherwise                       = ver
             modifyTVar' (routeMap or) (IntMap.adjust gotTimeout rid)
-            let expireRoute = writeTVar (pendingRoutes or IntMap.! rid) True
-            rr <- IntMap.lookup rid <$> readTVar (routeMap or)
             case rr of
-                Just RouteRecord{ responseCount=0
-                                , timeoutCount = c } | c >= 2 -> expireRoute
-                Just RouteRecord{ timeoutCount = c } | c >= 4 -> expireRoute
+                RouteRecord{ responseCount = 0
+                           , timeoutCount  = c
+                           , routeVersion = v } | c >= 2 -> expireRoute
+                RouteRecord{ timeoutCount = c
+                           , routeVersion = v } | c >= 5 -> expireRoute
                 _ -> return ()
-        writeTChan (routeLog or) $ "ONION query can " ++ show w8
+        writeTChan (routeLog or) $ "ONION query can " ++ show (fmap pendingVersion mb, w8)
         dispatchCancel tmethods tid d
     }