diff --git a/config/settings.yml b/config/settings.yml index edd5dbaf0..02598c3f6 100644 --- a/config/settings.yml +++ b/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" diff --git a/src/Cron.hs b/src/Cron.hs index d68f3f842..a17230f15 100644 --- a/src/Cron.hs +++ b/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 cronNext of - CronAsap - | addUTCTime cronMinInterval prevT <= now - -> MatchAsap - | otherwise - -> MatchAt $ addUTCTime cronMinInterval prevT - CronNotScheduled - | CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } <- cronNext - , now <= ts -> MatchAt ts - cronNext -> execRef (addUTCTime cronMinInterval prevT) True cronNext + = case cronRepeat of + CronRepeatOnChange + | not $ matchesCron tz Nothing prevT c + -> let + cutoffTime = addUTCTime cronRateLimit prevT + in case execRef now False cronInitial of + MatchAsap + | now < cutoffTime -> MatchAt cutoffTime + MatchAt ts + | ts < cutoffTime -> MatchAt cutoffTime + 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 diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs index 383ef0bf1..bb6753f73 100644 --- a/src/Cron/Types.hs +++ b/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 - { cronMinInterval :: NominalDiffTime - , cronNext :: CronAbsolute - } - deriving (Eq, Show) - -makeLenses_ ''CronPeriod +data CronRepeat + = CronRepeatOnChange + | CronRepeatScheduled CronAbsolute + | CronRepeatNever + deriving (Eq, Show, Read) data Cron = Cron { cronInitial :: CronAbsolute - , cronRepeat :: Maybe CronPeriod + , cronRepeat :: CronRepeat + , cronRateLimit :: NominalDiffTime } deriving (Eq, Show) diff --git a/src/Jobs.hs b/src/Jobs.hs index 09b861df2..c10c885a8 100644 --- a/src/Jobs.hs +++ b/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 - $logDebugS "waitUntil" [st|#{tshow diffT} (#{tshow waitTime'})|] + 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 - { cronMinInterval = interval - , cronNext = CronAsap - } + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = interval } Nothing -> return () @@ -372,10 +372,8 @@ determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do JobCtlDetermineCrontab Cron { cronInitial = CronAsap - , cronRepeat = Just CronPeriod - { cronMinInterval = appJobCronInterval - , cronNext = CronAsap - } + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = appJobCronInterval } let @@ -384,19 +382,15 @@ determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) Cron { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom - , cronRepeat = Just CronPeriod - { cronMinInterval = 3600 - , cronNext = CronNotScheduled -- Allow repetition of the notification (if something changes), but wait at least an hour - } + , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour + , cronRateLimit = appNotificationRateLimit } tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..}) Cron { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo - , cronRepeat = Just CronPeriod - { cronMinInterval = 3600 - , cronNext = CronNotScheduled - } + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit } runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs diff --git a/src/Settings.hs b/src/Settings.hs index 87ff88afe..79a3a8be4 100644 --- a/src/Settings.hs +++ b/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