Fix notification rate limiting

config/settings.yml

@@ -20,6 +20,7 @@ job-workers:        "_env:JOB_WORKERS:10"
 job-flush-interval: "_env:JOB_FLUSH:30"
 job-cron-interval:  "_env:CRON_INTERVAL:60"
 job-stale-threshold: 300
+notification-rate-limit: 3600
 
 detailed-logging:  "_env:DETAILED_LOGGING:false"
 should-log-all:    "_env:LOG_ALL:false"

src/Cron.hs

@@ -168,21 +168,28 @@ nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
 nextCronMatch tz mPrev now c@Cron{..}
   | isNothing mPrev
   = execRef now False cronInitial
-  | isJust mPrev
-  , isNothing cronRepeat
-  = MatchNone
   | Just prevT <- mPrev
-  , Just CronPeriod{..} <- cronRepeat
+  = case cronRepeat of
-  = case cronNext of
+      CronRepeatOnChange
-      CronAsap
+        | not $ matchesCron tz Nothing prevT c
-        | addUTCTime cronMinInterval prevT <= now
+          -> let
-          -> MatchAsap
+               cutoffTime = addUTCTime cronRateLimit prevT
-        | otherwise
+             in case execRef now False cronInitial of
-          -> MatchAt $ addUTCTime cronMinInterval prevT
+                  MatchAsap
-      CronNotScheduled
+                    | now < cutoffTime -> MatchAt cutoffTime
-        | CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } <- cronNext
+                  MatchAt ts 
-        , now <= ts -> MatchAt ts
+                    | ts < cutoffTime -> MatchAt cutoffTime
-      cronNext -> execRef (addUTCTime cronMinInterval prevT) True cronNext
+                  other -> other
+      CronRepeatScheduled cronNext
+        -> case cronNext of
+             CronAsap
+               | addUTCTime cronRateLimit prevT <= now
+                 -> MatchAsap
+               | otherwise
+                 -> MatchAt $ addUTCTime cronRateLimit prevT
+             cronNext
+               -> execRef (addUTCTime cronRateLimit prevT) True cronNext
+      _other -> MatchNone
   where
     execRef ref wasExecd cronAbsolute = case cronAbsolute of
       CronAsap -> MatchAsap
@@ -206,4 +213,16 @@ nextCronMatch tz mPrev now c@Cron{..}
         localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
         let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)
         return $ localTimeToUTCTZ tz LocalTime{..}
-      CronNotScheduled -> MatchNone
+
+matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
+            -> Maybe UTCTime -- ^ Previous execution of the job
+            -> UTCTime -- ^ "Current" time
+            -> Cron
+            -> Bool
+-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron`
+--   specification @c@ should match @now@, under the assumption that the next
+--   check will occur no earlier than @now + prec@.
+matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of
+  MatchAsap -> True
+  MatchNone -> False
+  MatchAt ts -> ts <= now

src/Cron/Types.hs

@@ -7,13 +7,12 @@ module Cron.Types
   ( Cron(..), Crontab
   , CronMatch(..)
   , CronAbsolute(..)
-  , CronPeriod(..)
+  , CronRepeat(..)
   ) where
 
 import ClassyPrelude
 
 import Utils.Lens.TH
-import Control.Lens
 
 import Data.Time 
 
@@ -48,17 +47,16 @@ data CronAbsolute
 
 makeLenses_ ''CronAbsolute
 
-data CronPeriod = CronPeriod
+data CronRepeat
-  { cronMinInterval :: NominalDiffTime
+  = CronRepeatOnChange
-  , cronNext :: CronAbsolute
+  | CronRepeatScheduled CronAbsolute
-  }
+  | CronRepeatNever
-  deriving (Eq, Show)
+  deriving (Eq, Show, Read)
-
-makeLenses_ ''CronPeriod
 
 data Cron = Cron
   { cronInitial :: CronAbsolute
-  , cronRepeat :: Maybe CronPeriod
+  , cronRepeat :: CronRepeat
+  , cronRateLimit :: NominalDiffTime
   }
   deriving (Eq, Show)
 

src/Jobs.hs

@@ -197,8 +197,10 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
     waitUntil crontabTV crontab nextTime = runResourceT $ do
       diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
       let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
-          waitTime' = realToFrac waitTime :: NominalDiffTime
+          waitTime'
-      $logDebugS "waitUntil" [st|#{tshow diffT} (#{tshow waitTime'})|]
+            | diffT < acc = "Done"
+            | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
+      $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
       if
         | diffT < acc -> return True
         | otherwise   -> do
@@ -360,10 +362,8 @@ determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do
       JobCtlFlush
       Cron
         { cronInitial = CronAsap
-        , cronRepeat = Just CronPeriod
+        , cronRepeat = CronRepeatScheduled CronAsap
-          { cronMinInterval = interval
+        , cronRateLimit = interval
-          , cronNext = CronAsap
-          }
         }
     Nothing -> return ()
 
@@ -372,10 +372,8 @@ determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do
     JobCtlDetermineCrontab
     Cron
       { cronInitial = CronAsap
-      , cronRepeat = Just CronPeriod
+      , cronRepeat = CronRepeatScheduled CronAsap
-        { cronMinInterval = appJobCronInterval
+      , cronRateLimit = appJobCronInterval
-        , cronNext = CronAsap
-        }
       }
 
   let
@@ -384,19 +382,15 @@ determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do
         (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
         Cron
           { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
-          , cronRepeat = Just CronPeriod
+          , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
-            { cronMinInterval = 3600
+          , cronRateLimit = appNotificationRateLimit
-            , cronNext = CronNotScheduled -- Allow repetition of the notification (if something changes), but wait at least an hour
-            }
           }
       tell $ HashMap.singleton
         (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
         Cron
           { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
-          , cronRepeat = Just CronPeriod
+          , cronRepeat = CronRepeatOnChange
-            { cronMinInterval = 3600
+          , cronRateLimit = appNotificationRateLimit
-            , cronNext = CronNotScheduled
-            }
           }
   runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
 

src/Settings.hs

@@ -86,6 +86,7 @@ data AppSettings = AppSettings
     , appJobFlushInterval       :: Maybe NominalDiffTime
     , appJobCronInterval        :: NominalDiffTime
     , appJobStaleThreshold      :: NominalDiffTime
+    , appNotificationRateLimit  :: NominalDiffTime
 
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
@@ -278,6 +279,7 @@ instance FromJSON AppSettings where
         appJobFlushInterval       <- o .:? "job-flush-interval"
         appJobCronInterval        <- o .:  "job-cron-interval"
         appJobStaleThreshold      <- o .:  "job-stale-threshold"
+        appNotificationRateLimit  <- o .:  "notification-rate-limit"
 
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev