Avoid overlapping searches.

1 files changed, 35 insertions, 20 deletions

diff --git a/dht/Announcer/Tox.hs b/dht/Announcer/Tox.hs
index 4b775049..e2459e0e 100644
--- a/dht/Announcer/Tox.hs
+++ b/dht/Announcer/Tox.hs
@@ -139,6 +139,7 @@ scheduleAnnounce :: Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
 scheduleAnnounce  announcer k AnnounceMethod{aSearch,aPublish,aNearestNodes,aTarget,aInterval} r = do
     st <- atomically $ newSearch aSearch aTarget []
     ns <- atomically $ newTVar MM.empty
+    mutex <- newMVar () -- This mutex insures one search at a time.
     let astate = AnnounceState st ns
         publishToNodes is = do
             forM_ is $ \(Binding ni mtok _) -> do
@@ -156,24 +157,29 @@ scheduleAnnounce  announcer k AnnounceMethod{aSearch,aPublish,aNearestNodes,aTar
         searchAgain = do
             -- Canceling a pending search here seems to make announcements more reliable.
             searchCancel st
-            isfin <- searchIsFinished st -- Always True, since we canceled.
-            return $ when isfin $ void $ fork search
+            return $ void $ do
+                t <- fork search
+                labelThread t ("scheduleAnnounce.sch." ++ show aTarget)
         search  = do -- thread to fork
-            atomically $ reset aNearestNodes aSearch aTarget st
-            searchLoop aSearch aTarget onResult st
-            fork $ do -- Announce to any nodes we haven't already announced to.
+            got <- tryTakeMVar mutex
+            case got of
+              Just () -> do
+                atomically $ reset aNearestNodes aSearch aTarget st
+                searchLoop aSearch aTarget onResult st
+                -- Announce to any nodes we haven't already announced to.
                 is <- atomically $ do
-                    bs <- readTVar (searchInformant st {- :: TVar (MinMaxPSQ' ni nid tok -})
-                    nq <- readTVar ns
-                    return $ filter (\(Binding ni _ _) -> not $ isJust $ MM.lookup' ni nq)
-                           $ MM.toList bs
+                        bs <- readTVar (searchInformant st {- :: TVar (MinMaxPSQ' ni nid tok -})
+                        nq <- readTVar ns
+                        return $ filter (\(Binding ni _ _) -> not $ isJust $ MM.lookup' ni nq)
+                               $ MM.toList bs
                 publishToNodes is
-            return ()
-            {-
-            atomically $ scheduleImmediately announcer k
-                         $ SearchFinished {- st -} search announce aInterval
-            interruptDelay (interrutible announcer)
-            -}
+                putMVar mutex ()
+              Nothing -> do
+                -- Previous search did not finish.  Instead of starting a new search,
+                -- we will re-announce only.
+                announce
+                -- Cancel search so that a new one can start in the nest period.
+                atomically $ searchCancel st
     atomically $ scheduleImmediately announcer k $ ScheduledItem (newAnnouncement searchAgain search announce aInterval)
 
 -- | Schedule a recurring Search + Publish sequence.
@@ -181,6 +187,7 @@ scheduleSearch :: Announcer -> AnnounceKey -> SearchMethod r -> r -> IO ()
 scheduleSearch announcer k SearchMethod{sSearch,sWithResult,sNearestNodes,sTarget,sInterval} r = do
     st <- atomically $ newSearch sSearch sTarget []
     ns <- atomically $ newTVar MM.empty
+    mutex <- newMVar () -- This mutex insures one search at a time.
     let astate = AnnounceState st ns
         onResult sr = do
                 runAction announcer "with-search-result" $ do
@@ -197,10 +204,18 @@ scheduleSearch announcer k SearchMethod{sSearch,sWithResult,sNearestNodes,sTarge
         searchAgain = do
             -- Canceling a pending search here seems to make announcements more reliable.
             searchCancel st
-            isfin <- searchIsFinished st -- Always True, since we canceled.
-            return $ when isfin $ void $ fork search
-        search  = do -- thread to fork
-            atomically $ reset sNearestNodes sSearch sTarget st
-            searchLoop sSearch sTarget onResult st
+            return $ void $ do
+                t <- fork search
+                labelThread t ("scheduleSearch.sch." ++ show sTarget)
+        search = do -- thread to fork
+            got <- tryTakeMVar mutex
+            case got of
+              Just () -> do
+                    atomically $ reset sNearestNodes sSearch sTarget st
+                    searchLoop sSearch sTarget onResult st
+                    putMVar mutex ()
+              Nothing -> do
+                -- Cancel search so that a new one can start in the nest period.
+                atomically $ searchCancel st
     atomically $ scheduleImmediately announcer k $ ScheduledItem (newAnnouncement searchAgain search (return ()) sInterval)