{-# LANGUAGE RecordWildCards #-} module System.Cron.Internal.Check where ------------------------------------------------------------------------------- import Control.Applicative as A import qualified Data.Foldable as FT import Data.List import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Semigroup (sconcat) import Data.Time (Day, DiffTime, UTCTime (..), addUTCTime, fromGregorianValid, toGregorian) import Data.Time.Calendar.WeekDate import qualified Data.Traversable as FT ------------------------------------------------------------------------------- import System.Cron.Types as CT ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Schedule projection ------------------------------------------------------------------------------- -- | Will return the next time from the given starting point where -- this schedule will match. Returns Nothing if the schedule will -- never match. Note that this function is not inclusive of the given -- time: the result will always be at least 1 minute beyond the given -- time. This is usually used to implement absolute timestamp -- schedulers. If you need to see multiple matches ahead, just keep -- feeding the result into nextMatch. Note that because nextMatch only -- returns Nothing on a schedule that will *never* be matched, it is -- safe to assume that if a schedule returns a Just once, it will -- always return a Just. nextMatch :: CronSchedule -> UTCTime -> Maybe UTCTime nextMatch cs@CronSchedule {..} now | domRestricted && dowRestricted = do -- this trick is courtesy of Python's croniter: run the schedule -- once with * in the DOM spot and once with * in the DOW slot -- and then choose the earlier of the two. domStarSpec <- mkDayOfMonthSpec (Field Star) dowStarSpec <- mkDayOfWeekSpec (Field Star) let domStarResult = nextMatch cs { dayOfMonth = domStarSpec } now let dowStarResult = nextMatch cs { CT.dayOfWeek = dowStarSpec} now listToMaybe (sort (catMaybes [domStarResult, dowStarResult])) | otherwise = do expanded@Expanded {..} <- expand cs let daysSource = validDays monthF domF startDay listToMaybe (nextMatches daysSource expanded now) where UTCTime startDay _ = addUTCTime 60 now domRestricted = restricted (dayOfMonthSpec dayOfMonth) dowRestricted = restricted (dayOfWeekSpec dayOfWeek) ------------------------------------------------------------------------------- nextMatches :: [Day] -> Expanded -> UTCTime -> [UTCTime] nextMatches daysSource Expanded {..} now = solutions where -- move to next minute solutions = filter validSolution [UTCTime d tod | d <- daysSource , tod <- validTODs hourF minF ] validSolution t = t > now && dowMatch t dowF ------------------------------------------------------------------------------- dowMatch :: UTCTime -> EField -> Bool dowMatch (UTCTime d _) dows = (getDOW d `FT.elem` dows) ------------------------------------------------------------------------------- -- | ISO8601 maps Sunday as 7 and Monday as 1, we want Sunday as 0 getDOW :: Day -> Int getDOW d | iso8601DOW == 7 = 0 | otherwise = iso8601DOW where (_, _, iso8601DOW) = toWeekDate d ------------------------------------------------------------------------------- validDays :: EField -> EField -> Day -> [Day] validDays months days start = concat (firstYearDates:subsequentYearDates) where (startYear, startMonth, _) = toGregorian start firstYearMonths = dropWhile (< startMonth) subsequentYearMonths subsequentYearMonths = sortBy compare (FT.toList months) firstYearDates = dateSequence firstYearMonths startYear subsequentYearDates = [ dateSequence subsequentYearMonths y | y <- [startYear+1..]] dateSequence mseq y = catMaybes [fromGregorianValid y m d | m <- mseq , d <- sortBy compare (FT.toList days)] ------------------------------------------------------------------------------- -- | Guarantees: the Expanded will be satisfiable (no invalid dates, -- no empties). dow 7 will be normalized to 0 (Sunday) expand :: CronSchedule -> Maybe Expanded expand CronSchedule {..} = do expanded <- Expanded A.<$> minF' <*> hourF' <*> domF' <*> monthF' <*> dowF' if satisfiable expanded then Just expanded else Nothing where minF' = expandF (0, 59) (minuteSpec minute) hourF' = expandF (0, 23) (hourSpec hour) domF' = expandF (1, 31) (dayOfMonthSpec dayOfMonth) monthF' = expandF (1, 12) (monthSpec month) dowF' = remapSunday <$> expandF (0, 7) (dayOfWeekSpec dayOfWeek) remapSunday lst = case NE.partition (\n -> n == 0 || n == 7) lst of ([], _) -> lst (_, noSunday) -> 0 :| noSunday domRestricted = restricted (dayOfMonthSpec dayOfMonth) dowRestricted = restricted (dayOfWeekSpec dayOfWeek) -- If DOM and DOW are restricted, they are ORed, so even if -- there's an invalid day for the month, it is still satisfiable -- because it will just choose the DOW path satisfiable Expanded {..} = (domRestricted && dowRestricted) || or [hasValidForMonth m domF | m <- (FT.toList monthF)] ------------------------------------------------------------------------------- expandF :: (Int, Int) -> CronField -> Maybe EField expandF rng (Field f) = expandBF rng f expandF rng (ListField fs) = NE.nub . sconcat <$> FT.mapM (expandBF rng) fs expandF rng (StepField' sf) = expandBFStepped rng (sfField sf) (sfStepping sf) ------------------------------------------------------------------------------- expandBFStepped :: (Int, Int) -> BaseField -> Int -> Maybe EField expandBFStepped rng Star step = NE.nonEmpty (fillTo rng step) expandBFStepped (_, unitMax) (RangeField' rf) step = NE.nonEmpty (fillTo (start, finish') step) where finish' = min finish unitMax start = rfBegin rf finish = rfEnd rf expandBFStepped (_, unitMax) (SpecificField' sf) step = expandBFStepped (startAt, unitMax) Star step where startAt = specificField sf ------------------------------------------------------------------------------- fillTo :: (Int, Int) -> Int -> [Int] fillTo (start, finish) step | step <= 0 = [] | finish < start = [] | otherwise = takeWhile (<= finish) nums where nums = [ start + (step * iter) | iter <- [0..]] ------------------------------------------------------------------------------- expandBF :: (Int, Int) -> BaseField -> Maybe EField expandBF (lo, hi) Star = Just (NE.fromList (enumFromTo lo hi)) expandBF _ (SpecificField' sf) = Just (specificField sf :| []) expandBF _ (RangeField' rf) = Just (NE.fromList (enumFromTo (rfBegin rf) (rfEnd rf))) ------------------------------------------------------------------------------- validTODs :: EField -> EField -> [DiffTime] validTODs hrs mns = dtSequence where minuteSequence = sortBy compare (FT.toList mns) hourSequence = sortBy compare (FT.toList hrs) -- order here ensures we'll count up minutes before hours dtSequence = [ todToDiffTime hr mn | hr <- hourSequence, mn <- minuteSequence] ------------------------------------------------------------------------------- todToDiffTime :: Int -> Int -> DiffTime todToDiffTime nextHour nextMin = fromIntegral ((nextHour * 60 * 60) + nextMin * 60) ------------------------------------------------------------------------------- timeOfDay :: DiffTime -> (Int, Int) timeOfDay t = (h, m) where seconds = floor t minutes = seconds `div` 60 (h, m) = minutes `divMod` 60 ------------------------------------------------------------------------------- hasValidForMonth :: Int -- ^ Month -> EField -> Bool hasValidForMonth 1 days = FT.minimum days <= 31 hasValidForMonth 2 days = FT.minimum days <= 29 hasValidForMonth 3 days = FT.minimum days <= 31 hasValidForMonth 4 days = FT.minimum days <= 30 hasValidForMonth 5 days = FT.minimum days <= 31 hasValidForMonth 6 days = FT.minimum days <= 30 hasValidForMonth 7 days = FT.minimum days <= 31 hasValidForMonth 8 days = FT.minimum days <= 31 hasValidForMonth 9 days = FT.minimum days <= 30 hasValidForMonth 10 days = FT.minimum days <= 31 hasValidForMonth 11 days = FT.minimum days <= 30 hasValidForMonth 12 days = FT.minimum days <= 31 hasValidForMonth _ _ = False ------------------------------------------------------------------------------- data Expanded = Expanded { minF :: EField , hourF :: EField , domF :: EField , monthF :: EField , dowF :: EField } deriving (Show) ------------------------------------------------------------------------------- -- This could be an intmap but I'm not convinced there's significant -- performance to be gained type EField = NonEmpty Int -- | Does the given cron schedule match for the given timestamp? This -- is usually used for implementing polling-type schedulers like cron -- itself. scheduleMatches :: CronSchedule -> UTCTime -> Bool scheduleMatches cs@CronSchedule {..} (UTCTime d t) = maybe False go (expand cs) where go Expanded {..} = and [ FT.elem mn minF , FT.elem hr hourF , FT.elem mth monthF , checkDOMAndDOW ] where -- turns out if neither dom and dow are stars, you're supposed to -- OR and not AND them: -- -- Note: The day of a command's execution can -- be specified by two fields — day of month, and day of week. If -- both fields are restricted (i.e., aren't *), the command will -- be run when either field matches the current time. For example, -- ``30 4 1,15 * 5'' would cause a command to be run at 4:30 am on -- the 1st and 15th of each month, plus every Friday. One can, -- however, achieve the desired result by adding a test to the -- command (see the last example in EXAMPLE CRON FILE below). checkDOMAndDOW | restricted (dayOfMonthSpec dayOfMonth) && restricted (dayOfWeekSpec dayOfWeek) = domMatches || dowMatches | otherwise = domMatches && dowMatches domMatches = FT.elem dom domF dowMatches = FT.elem dow dowF (_, mth, dom) = toGregorian d (hr, mn) = timeOfDay t dow = getDOW d restricted :: CronField -> Bool restricted = not . isStar isStar :: CronField -> Bool isStar (Field Star) = True isStar (ListField bfs) = FT.any (== Star) bfs isStar (StepField' sf) = sfField sf == Star && sfStepping sf == 1 isStar _ = False