wip8

hbs2-peer/app/BlockDownloadNew.hs

@@ -52,8 +52,13 @@ import Numeric
 import UnliftIO
 import Control.Concurrent.STM.TSem (TSem)
 import Control.Concurrent.STM.TSem qualified as TSem
+
 import UnliftIO.Concurrent
 import UnliftIO.STM
+import UnliftIO.Exception as U
+
+import Control.Exception qualified as E
+
 import Lens.Micro.Platform
 import System.Random
 import System.Random.Shuffle (shuffleM,shuffle')
@@ -582,6 +587,13 @@ data DCB =
 newDcbSTM :: TimeSpec -> Maybe HashRef -> STM DCB
 newDcbSTM ts parent = DCB ts parent <$> newTVar 0 <*> newTVar False
 
+
+data DownloadSweepOnIdle =
+  DownloadSweepOnIdle
+  deriving stock (Show,Typeable)
+
+instance Exception DownloadSweepOnIdle
+
 data PSt =
     PChoose
   | PInit         HashRef DCB
@@ -596,8 +608,9 @@ downloadDispatcher :: forall e m . ( e ~ L4Proto
                  -> SomeBrains e
                  -> PeerEnv e
                  -> m ()
-downloadDispatcher probe brains env = flip runContT pure do
+downloadDispatcher probe brains env = forever $ flip runContT pure do
 
+    debug $ red "downloadDispatcher spawned!"
 
     pts   <- newTVarIO ( mempty :: HashMap (Peer e) (Async (), PeerNonce) )
 
@@ -621,6 +634,9 @@ downloadDispatcher probe brains env = flip runContT pure do
         atomically $ insertNewDownloadSTM now ha
         newDownload @e brains ha
 
+    void $ ContT $ bracket none $ const do
+      readTVarIO pts <&> fmap fst . HM.elems >>= mapM_ cancel
+
     void $ ContT $ withAsync $ manageThreads onBlockSTM wip pts
 
     sto <- withPeerM env getStorage
@@ -680,17 +696,33 @@ downloadDispatcher probe brains env = flip runContT pure do
       missed <- findMissedBlocks sto what
       for_ missed insertNewDownload
 
-  forever $ (>> pause @'Seconds 10) do
+    idle <- ContT $ withAsync $ do
+      t0 <- getTimeCoarse
+      flip fix t0 $ \next ti -> do
+        num <- readTVarIO wip <&> HM.size
+        t1 <- getTimeCoarse
+        if num /= 0 then do
+          pause @Seconds 5 >> next t1
+        else do
+          let idle = expired (TimeoutSec 600) (t1 - ti)
+          -- debug $ blue "EXPIRED" <+> pretty (idle,t1,ti)
+          when idle $ throwIO DownloadSweepOnIdle
+          pause @Seconds 5
+          next t0
+
+    ContT $ withAsync $ forever $ (>> pause @'Seconds 10) do
       sw0  <- readTVarIO wip <&> HM.size
       n    <- countDownloads @e brains
       debug $ yellow $ "wip" <+> pretty sw0 <+> parens (pretty n)
 
+    void $ waitCatch idle
+
   where
 
-    manageThreads :: (HashRef -> STM ())
+    -- manageThreads :: (HashRef -> STM ())
-                  -> TVar (HashMap HashRef DCB)
+    --               -> TVar (HashMap HashRef DCB)
-                  -> TVar (HashMap (Peer e) (Async (), PeerNonce))
+    --               -> TVar (HashMap (Peer e) (Async (), PeerNonce))
-                  -> m ()
+    --               -> m ()
 
     manageThreads onBlock wip pts = do
       _pnum <- newTVarIO 1
@@ -711,7 +743,6 @@ downloadDispatcher probe brains env = flip runContT pure do
                      maybe1 mpd (pure ()) $
                         \PeerData{..} -> S.yield (p, _peerOwnNonce)
 
-
         for_ (HM.toList peers) $ \(p,nonce) -> do
           here <- readTVarIO pts <&> HM.member p