1 files changed, 30 insertions, 20 deletions

diff --git a/Announcer.hs b/Announcer.hs
index 3928890c..1b6cd631 100644
--- a/Announcer.hs
+++ b/Announcer.hs
@@ -19,6 +19,8 @@ module Announcer
     , itemStatusNum
     , runAction
     , unschedule
+    , delayAction
+    , scheduleRel
 
     -- lower level, Announcer.Tox needs these.
     , scheduleImmediately
@@ -96,17 +98,20 @@ data Announcer = Announcer
     , commander :: TChan SchedulerCommand
     }
 
--- | Schedules an event to occur long ago at the epoch (which effectively makes
--- the event happen as soon as possible).  Note that the caller will usually
--- also want to interrupt the 'interrutible' delay so that it finds this item
--- immediately.
 scheduleImmediately :: Announcer -> AnnounceKey -> ScheduledItem -> STM ()
-scheduleImmediately announcer k item = scheduleAbs announcer k item 0
+scheduleImmediately announcer k item =
+    writeTChan (commander announcer) $ RunActionSTM k item
 
 scheduleAbs :: Announcer -> AnnounceKey -> ScheduledItem -> POSIXTime -> STM ()
 scheduleAbs announcer k item absTime =
     writeTChan (commander announcer) $ ScheduleAction (k, absTime, item)
 
+scheduleRel, delayAction :: Announcer -> AnnounceKey -> ScheduledItem -> POSIXTime -> STM ()
+scheduleRel announcer k item relTime =
+    writeTChan (commander announcer) $ DelayAction (k, relTime, item)
+
+delayAction = scheduleRel
+
 runAction :: Announcer -> IO () -> STM ()
 runAction announcer = writeTChan (commander announcer) . RunAction
 
@@ -134,13 +139,18 @@ forkAnnouncer = do
 
 readTChanTimeout :: TVar Bool -> TChan a -> STM (Maybe a)
 readTChanTimeout delay pktChannel = do
-  -- delay <- registerDelay (toMicroseconds timeout)
   Just <$> readTChan pktChannel <|> pure Nothing <* (readTVar >=> check) delay
 
 toMicroseconds :: POSIXTime -> Int
 toMicroseconds = round . (* 1000) . (* 1000)
 
-data SchedulerCommand = ShutdownScheduler | ScheduleAction KPS | RunAction (IO ()) | UnscheduleAction AnnounceKey
+data SchedulerCommand
+  = ShutdownScheduler
+  | ScheduleAction KPS -- run an action at an absolute time (todo: use UTCTime)
+  | DelayAction KPS    -- run an action at a time relative to the present (todo: use NominalDiffTime)
+  | RunAction (IO ())
+  | RunActionSTM AnnounceKey ScheduledItem
+  | UnscheduleAction AnnounceKey
 
 listener :: Announcer -> IO ()
 listener announcer = relisten
@@ -166,20 +176,20 @@ listener announcer = relisten
               Nothing  -> do
                 writeTVar (scheduled announcer) (Schedule queue')
                 (fmap (>> relisten) (fmap fork (f announcer k now)))
-
       where
-        modifyScheduled f = modifyTVar (scheduled announcer) (Schedule . f . unSchedule)
-        declareInactive = writeTVar (announcerActive announcer) False
-        handleCommand =
-          \case
-            ShutdownScheduler -> atomically declareInactive
-            RunAction io -> io >> relisten
-            UnscheduleAction k -> do
-              atomically $ modifyScheduled $ PSQ.delete k
-              relisten
-            ScheduleAction (k, p, s) -> do
-              atomically $ modifyScheduled $ PSQ.insert' k s p
-              relisten
+        modifyScheduled f               = modifyTVar (scheduled announcer) (Schedule . f . unSchedule)
+        declareInactive                 = writeTVar (announcerActive announcer) False
+        handleCommand ShutdownScheduler = atomically declareInactive
+        handleCommand cmd               = (>> relisten) $
+          case cmd of
+            ScheduleAction (k, p, s) -> atomically $ modifyScheduled $ PSQ.insert' k s p
+            UnscheduleAction k       -> atomically $ modifyScheduled $ PSQ.delete k
+            RunActionSTM k (ScheduledItem f) -> do
+              now <- getPOSIXTime
+              join (atomically $ f announcer k now)
+            DelayAction (k, p, s) -> do
+              now <- getPOSIXTime
+              atomically $ modifyScheduled $ PSQ.insert' k s (now + p)
 
 announceThread :: Announcer -> IO ()
 announceThread announcer = do