cron-0.7.2: src/System/Cron/Internal/Check.hs
{-# 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 (toWeekDate)
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