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
import Data.Time.Calendar.WeekDate
import qualified Data.Traversable as FT
import System.Cron.Types
nextMatch :: CronSchedule -> UTCTime -> Maybe UTCTime
nextMatch cs@CronSchedule {..} now
| domRestricted && dowRestricted = do
domStarSpec <- mkDayOfMonthSpec (Field Star)
dowStarSpec <- mkDayOfWeekSpec (Field Star)
let domStarResult = nextMatch cs { dayOfMonth = domStarSpec } now
let dowStarResult = nextMatch cs { 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
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)
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)]
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)
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)
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
-> 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)
type EField = NonEmpty Int
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
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