abstraction for batched callbacks

3 files changed, 42 insertions, 0 deletions

diff --git a/fastbangs.cabal b/fastbangs.cabal
index e6eb3c6..689548e 100644
--- a/fastbangs.cabal
+++ b/fastbangs.cabal
@@ -19,6 +19,7 @@ executable fastbangs
   other-modules:
       Auth
       BangState
+      BatchedRunner
       Config
       Data.Bang
       Data.PendingBang
diff --git a/src/BatchedRunner.hs b/src/BatchedRunner.hs
new file mode 100644
index 0000000..83a704c
--- /dev/null
+++ b/src/BatchedRunner.hs
@@ -0,0 +1,40 @@
+module BatchedRunner (
+    Runner,
+    makeRunner,
+    stopRunner,
+    notifyRunner,
+    withRunner
+) where
+
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.STM.TMVar
+import Control.Exception (bracket)
+import Control.Monad.STM
+import Control.Monad (unless, void)
+import Data.Maybe (fromMaybe)
+
+newtype Runner = Runner (TMVar Bool)
+
+makeRunner :: IO a -> Int {- µs -} -> IO Runner
+makeRunner f n = do
+    mv <- newEmptyTMVarIO
+    _ <- forkIO $ runnerLoop mv
+    return $ Runner mv
+
+  where runnerLoop mv = do
+            b <- atomically $ takeTMVar mv
+            unless b $ do
+                threadDelay n
+                -- clear the TMVar; we're running f now
+                mayB <- atomically $ tryTakeTMVar mv
+                _ <- f
+                unless (fromMaybe False mayB) $ runnerLoop mv
+
+stopRunner :: Runner -> IO ()
+stopRunner (Runner mv) = atomically $ putTMVar mv True
+
+notifyRunner :: Runner -> IO ()
+notifyRunner (Runner mv) = void $ atomically $ tryPutTMVar mv False
+
+withRunner :: IO a -> Int -> (Runner -> IO b) -> IO b
+withRunner f n = bracket (makeRunner f n) stopRunner
diff --git a/src/Main.hs b/src/Main.hs
index ec4204a..049e709 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -20,6 +20,7 @@ import Auth
 import BangState
 import Config
 import Data.PendingBang
+import BatchedRunner
 
 data Search = Search {
     bangState :: BangState,