From acd36a513cb3181baffbb14eea6391d88801339e Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Sun, 12 Nov 2023 07:43:47 +0300
Subject: [PATCH] polling-to-separate-module

---
 hbs2-core/hbs2-core.cabal     |  2 ++
 hbs2-core/lib/HBS2/Polling.hs | 61 +++++++++++++++++++++++++++++++++++
 hbs2-peer/app/PeerTypes.hs    | 51 ++---------------------------
 3 files changed, 65 insertions(+), 49 deletions(-)
 create mode 100644 hbs2-core/lib/HBS2/Polling.hs

diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal
index 52974980..9b9f9c7c 100644
--- a/hbs2-core/hbs2-core.cabal
+++ b/hbs2-core/hbs2-core.cabal
@@ -90,6 +90,7 @@ library
                     , HBS2.Data.Bundle
                     , HBS2.Defaults
                     , HBS2.Events
+                    , HBS2.Polling
                     , HBS2.Hash
                     , HBS2.Merkle
                     , HBS2.Net.Auth.GroupKeyAsymm
@@ -166,6 +167,7 @@ library
                     , exceptions
                     , generic-lens
                     , hashable
+                    , heaps
                     , interpolatedstring-perl6
                     , iproute
                     , memory
diff --git a/hbs2-core/lib/HBS2/Polling.hs b/hbs2-core/lib/HBS2/Polling.hs
new file mode 100644
index 00000000..a2f318ff
--- /dev/null
+++ b/hbs2-core/lib/HBS2/Polling.hs
@@ -0,0 +1,61 @@
+module HBS2.Polling where
+
+import HBS2.Prelude.Plated
+import HBS2.Clock
+
+import Data.Heap (Entry(..))
+import Data.Heap qualified as Heap
+import Data.Time.Clock
+import Data.HashMap.Strict qualified as HashMap
+import Lens.Micro.Platform
+import Data.Function
+
+data Polling =
+  Polling
+  { waitBefore   :: NominalDiffTime
+  , waitOnEmpty  :: NominalDiffTime
+  }
+
+polling :: forall a m . (MonadIO m, Hashable a)
+        => Polling
+        -> m [(a, NominalDiffTime)]
+        -> (a -> m ())
+        -> m ()
+
+polling o listEntries action = do
+
+  -- FIXME: might-be-concurrent
+
+  pause (TimeoutNDT (waitBefore o))
+
+  now0 <- getTimeCoarse
+  refs0 <- listEntries <&> fmap (set _2 now0) <&> HashMap.fromList
+
+  fix (\next mon -> do
+    now <- getTimeCoarse
+    refs <- listEntries <&> HashMap.fromList
+    let mon' = mon `HashMap.union`
+                 HashMap.fromList [ (e, now + toTimeSpec (TimeoutNDT t))
+                                  | (e, t) <- HashMap.toList refs
+                                  ]
+
+    let q = Heap.fromList [ Entry t e
+                          | (e, t) <- HashMap.toList mon'
+                          ]
+
+    case Heap.uncons q of
+      Just (Entry t r, _) | t <= now -> do
+        action r
+        next (HashMap.delete r mon')
+
+      Just (Entry t _, _) | otherwise -> do
+        pause (TimeoutTS (t - now))
+        next mon'
+
+      Nothing -> do
+        pause (TimeoutNDT (waitOnEmpty o))
+        next mon'
+
+    ) refs0
+
+
diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs
index eb93fcf2..2112802c 100644
--- a/hbs2-peer/app/PeerTypes.hs
+++ b/hbs2-peer/app/PeerTypes.hs
@@ -6,8 +6,10 @@
 module PeerTypes
   ( module PeerTypes
   , module HBS2.Net.PeerLocator
+  , module HBS2.Polling
   ) where
 
+import HBS2.Polling
 import HBS2.Actors.Peer
 import HBS2.Clock
 import HBS2.Data.Types.SignedBox
@@ -486,55 +488,6 @@ checkDownloaded hr = do
 
   pure $ null missed
 
-data Polling =
-  Polling
-  { waitBefore   :: NominalDiffTime
-  , waitOnEmpty  :: NominalDiffTime
-  }
-
-polling :: forall a m . (MonadIO m, Hashable a)
-        => Polling
-        -> m [(a, NominalDiffTime)]
-        -> (a -> m ())
-        -> m ()
-
-polling o listEntries action = do
-
-  -- FIXME: might-be-concurrent
-
-  pause (TimeoutNDT (waitBefore o))
-
-  now0 <- getTimeCoarse
-  refs0 <- listEntries <&> fmap (set _2 now0) <&> HashMap.fromList
-
-  fix (\next mon -> do
-    now <- getTimeCoarse
-    refs <- listEntries <&> HashMap.fromList
-    let mon' = mon `HashMap.union`
-                 HashMap.fromList [ (e, now + toTimeSpec (TimeoutNDT t))
-                                  | (e, t) <- HashMap.toList refs
-                                  ]
-
-    let q = Heap.fromList [ Entry t e
-                          | (e, t) <- HashMap.toList mon'
-                          ]
-
-    case Heap.uncons q of
-      Just (Entry t r, _) | t <= now -> do
-        action r
-        next (HashMap.delete r mon')
-
-      Just (Entry t _, _) | otherwise -> do
-        pause (TimeoutTS (t - now))
-        next mon'
-
-      Nothing -> do
-        pause (TimeoutNDT (waitOnEmpty o))
-        next mon'
-
-    ) refs0
-
-
 instance (ForGossip e p (PeerM e IO)) => HasGossip e p (PeerM e IO) where
   gossip msg = do
     broadCastMessage msg