Generalizing Announcer, re-interpreted Announce/NewAnnouncement items.

1 files changed, 29 insertions, 18 deletions

diff --git a/Announcer.hs b/Announcer.hs
index e9d83e65..7fd72e2d 100644
--- a/Announcer.hs
+++ b/Announcer.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE NamedFieldPuns             #-}
@@ -57,9 +58,6 @@ unpackAnnounceKey _ (AnnounceKey bs) = return $ Char8.unpack bs
 -- 'Announce'.
 data ScheduledItem
     = DeleteAnnouncement
-      -- NewAnnouncement searchAgain search announce aInterval
-    | NewAnnouncement (STM (IO ())) (IO ()) (IO ()) POSIXTime
-    | Announce (STM (IO ())) (IO ()) POSIXTime
     | ScheduledItem (Announcer -> AnnounceKey -> POSIXTime -> STM (IO ()))
     | StopAnnouncer
  -- Can't use Data because STM and IO. :(
@@ -72,10 +70,8 @@ data ScheduledItem
 
 itemStatusNum :: ScheduledItem -> Int
 itemStatusNum (DeleteAnnouncement   ) = 0
-itemStatusNum (NewAnnouncement    {}) = 1
-itemStatusNum (Announce           {}) = 2
-itemStatusNum (ScheduledItem      {}) = 3
-itemStatusNum (StopAnnouncer        ) = 4
+itemStatusNum (ScheduledItem      {}) = 1
+itemStatusNum (StopAnnouncer        ) = 2
 itemStatusNum _                       = error "itemStatusNum not in sync with ScheduledItem declaration."
 
 data Announcer = Announcer
@@ -215,7 +211,7 @@ schedule announcer k AnnounceMethod{aSearch,aPublish,aBuckets,aTarget,aInterval}
                          $ SearchFinished {- st -} search announce aInterval
             interruptDelay (interrutible announcer)
             -}
-    atomically $ scheduleImmediately announcer k $ NewAnnouncement searchAgain search announce aInterval
+    atomically $ scheduleImmediately announcer k $ ScheduledItem (newAnnouncement searchAgain search announce aInterval)
     interruptDelay (interrutible announcer)
 
 cancel :: Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
@@ -277,20 +273,35 @@ performScheduledItem announcer now = \case
 
     (Binding k (ScheduledItem action) _) -> Just <$> action announcer k now
 
-    -- announcement started:
-    (Binding k (NewAnnouncement checkFin search announce interval) _) -> do
+-- announcement started:
+newAnnouncement :: STM (IO a)
+                         -> IO ()
+                         -> IO ()
+                         -> POSIXTime
+                         -> Announcer
+                         -> AnnounceKey
+                         -> POSIXTime
+                         -> STM (IO ())
+newAnnouncement checkFin search announce interval = \announcer k now -> do
         modifyTVar (scheduled announcer)
-                   (PSQ.insert' k (Announce checkFin announce interval) (now + interval))
-        return $ Just $ void $ fork search
+                   (PSQ.insert' k (ScheduledItem $ reAnnounce checkFin announce interval) (now + interval))
+        return $ void $ fork search
 
-    -- time for periodic announce:
-    --   (re-)announce to the current known set of storing-nodes.
-    --   TODO: If the search is finished, restart the search.
-    (Binding k (Announce checkFin announce interval) _) -> do
+-- time for periodic announce:
+--   (re-)announce to the current known set of storing-nodes.
+--   TODO: If the search is finished, restart the search.
+reAnnounce :: STM (IO a)
+                    -> IO ()
+                    -> POSIXTime
+                    -> Announcer
+                    -> AnnounceKey
+                    -> POSIXTime
+                    -> STM (IO ())
+reAnnounce checkFin announce interval = \announcer k now -> do
         isfin <- checkFin
         modifyTVar (scheduled announcer)
-                   (PSQ.insert' k (Announce checkFin announce interval) (now + interval))
-        return $ Just $ do
+                   (PSQ.insert' k (ScheduledItem $ reAnnounce checkFin announce interval) (now + interval))
+        return $ do
             isfin
             hPutStrLn stderr $ "This print avoids negative-time future scheduling. Weird bug. TODO: fix it. "++show now
             announce