polling-to-separate-module

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

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
+
+

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