{-# 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 :: CronSchedule -> UTCTime -> Maybe UTCTime
nextMatch cs :: CronSchedule
cs@CronSchedule {DayOfWeekSpec
MonthSpec
DayOfMonthSpec
HourSpec
MinuteSpec
minute :: MinuteSpec
hour :: HourSpec
dayOfMonth :: DayOfMonthSpec
month :: MonthSpec
dayOfWeek :: DayOfWeekSpec
minute :: CronSchedule -> MinuteSpec
hour :: CronSchedule -> HourSpec
dayOfMonth :: CronSchedule -> DayOfMonthSpec
month :: CronSchedule -> MonthSpec
dayOfWeek :: CronSchedule -> DayOfWeekSpec
..} UTCTime
now
  | Bool
domRestricted Bool -> Bool -> Bool
&& Bool
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.
      DayOfMonthSpec
domStarSpec <- CronField -> Maybe DayOfMonthSpec
mkDayOfMonthSpec (BaseField -> CronField
Field BaseField
Star)
      DayOfWeekSpec
dowStarSpec <- CronField -> Maybe DayOfWeekSpec
mkDayOfWeekSpec (BaseField -> CronField
Field BaseField
Star)
      let domStarResult :: Maybe UTCTime
domStarResult = CronSchedule -> UTCTime -> Maybe UTCTime
nextMatch CronSchedule
cs { dayOfMonth = domStarSpec } UTCTime
now
      let dowStarResult :: Maybe UTCTime
dowStarResult = CronSchedule -> UTCTime -> Maybe UTCTime
nextMatch CronSchedule
cs { CT.dayOfWeek = dowStarSpec} UTCTime
now
      [UTCTime] -> Maybe UTCTime
forall a. [a] -> Maybe a
listToMaybe ([UTCTime] -> [UTCTime]
forall a. Ord a => [a] -> [a]
sort ([Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes [Maybe UTCTime
domStarResult, Maybe UTCTime
dowStarResult]))
  | Bool
otherwise = do
    expanded :: Expanded
expanded@Expanded {NonEmpty Int
minF :: NonEmpty Int
hourF :: NonEmpty Int
domF :: NonEmpty Int
monthF :: NonEmpty Int
dowF :: NonEmpty Int
minF :: Expanded -> NonEmpty Int
hourF :: Expanded -> NonEmpty Int
domF :: Expanded -> NonEmpty Int
monthF :: Expanded -> NonEmpty Int
dowF :: Expanded -> NonEmpty Int
..} <- CronSchedule -> Maybe Expanded
expand CronSchedule
cs
    let daysSource :: [Day]
daysSource = NonEmpty Int -> NonEmpty Int -> Day -> [Day]
validDays NonEmpty Int
monthF NonEmpty Int
domF Day
startDay
    [UTCTime] -> Maybe UTCTime
forall a. [a] -> Maybe a
listToMaybe ([Day] -> Expanded -> UTCTime -> [UTCTime]
nextMatches [Day]
daysSource Expanded
expanded UTCTime
now)
  where
    UTCTime Day
startDay DiffTime
_ = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
60 UTCTime
now
    domRestricted :: Bool
domRestricted = CronField -> Bool
restricted (DayOfMonthSpec -> CronField
dayOfMonthSpec DayOfMonthSpec
dayOfMonth)
    dowRestricted :: Bool
dowRestricted = CronField -> Bool
restricted (DayOfWeekSpec -> CronField
dayOfWeekSpec DayOfWeekSpec
dayOfWeek)


-------------------------------------------------------------------------------
nextMatches :: [Day] -> Expanded -> UTCTime -> [UTCTime]
nextMatches :: [Day] -> Expanded -> UTCTime -> [UTCTime]
nextMatches [Day]
daysSource Expanded {NonEmpty Int
minF :: Expanded -> NonEmpty Int
hourF :: Expanded -> NonEmpty Int
domF :: Expanded -> NonEmpty Int
monthF :: Expanded -> NonEmpty Int
dowF :: Expanded -> NonEmpty Int
minF :: NonEmpty Int
hourF :: NonEmpty Int
domF :: NonEmpty Int
monthF :: NonEmpty Int
dowF :: NonEmpty Int
..} UTCTime
now = [UTCTime]
solutions
  where
    -- move to next minute
    solutions :: [UTCTime]
solutions = (UTCTime -> Bool) -> [UTCTime] -> [UTCTime]
forall a. (a -> Bool) -> [a] -> [a]
filter UTCTime -> Bool
validSolution [Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tod
                                     | Day
d <- [Day]
daysSource
                                     , DiffTime
tod <- NonEmpty Int -> NonEmpty Int -> [DiffTime]
validTODs NonEmpty Int
hourF NonEmpty Int
minF
                                     ]
    validSolution :: UTCTime -> Bool
validSolution UTCTime
t = UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now Bool -> Bool -> Bool
&& UTCTime -> NonEmpty Int -> Bool
dowMatch UTCTime
t NonEmpty Int
dowF


-------------------------------------------------------------------------------
dowMatch :: UTCTime -> EField -> Bool
dowMatch :: UTCTime -> NonEmpty Int -> Bool
dowMatch (UTCTime Day
d DiffTime
_) NonEmpty Int
dows = (Day -> Int
getDOW Day
d Int -> NonEmpty Int -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`FT.elem` NonEmpty Int
dows)


-------------------------------------------------------------------------------
-- | ISO8601 maps Sunday as 7 and Monday as 1, we want Sunday as 0
getDOW :: Day -> Int
getDOW :: Day -> Int
getDOW Day
d
  | Int
iso8601DOW Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 = Int
0
  | Bool
otherwise       = Int
iso8601DOW
  where
    (Year
_, Int
_, Int
iso8601DOW) = Day -> (Year, Int, Int)
toWeekDate Day
d


-------------------------------------------------------------------------------
validDays :: EField -> EField -> Day -> [Day]
validDays :: NonEmpty Int -> NonEmpty Int -> Day -> [Day]
validDays NonEmpty Int
months NonEmpty Int
days Day
start =
  [[Day]] -> [Day]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Day]
firstYearDates[Day] -> [[Day]] -> [[Day]]
forall a. a -> [a] -> [a]
:[[Day]]
subsequentYearDates)
  where
    (Year
startYear, Int
startMonth, Int
_) = Day -> (Year, Int, Int)
toGregorian Day
start
    firstYearMonths :: [Int]
firstYearMonths = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
startMonth) [Int]
subsequentYearMonths
    subsequentYearMonths :: [Int]
subsequentYearMonths = (Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FT.toList NonEmpty Int
months)
    firstYearDates :: [Day]
firstYearDates = [Int] -> Year -> [Day]
dateSequence [Int]
firstYearMonths Year
startYear
    subsequentYearDates :: [[Day]]
subsequentYearDates = [ [Int] -> Year -> [Day]
dateSequence [Int]
subsequentYearMonths Year
y | Year
y <- [Year
startYearYear -> Year -> Year
forall a. Num a => a -> a -> a
+Year
1..]]
    dateSequence :: [Int] -> Year -> [Day]
dateSequence [Int]
mseq Year
y = [Maybe Day] -> [Day]
forall a. [Maybe a] -> [a]
catMaybes [Year -> Int -> Int -> Maybe Day
fromGregorianValid Year
y Int
m Int
d
                                    | Int
m <- [Int]
mseq
                                    , Int
d <- (Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FT.toList NonEmpty Int
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 -> Maybe Expanded
expand CronSchedule {DayOfWeekSpec
MonthSpec
DayOfMonthSpec
HourSpec
MinuteSpec
minute :: CronSchedule -> MinuteSpec
hour :: CronSchedule -> HourSpec
dayOfMonth :: CronSchedule -> DayOfMonthSpec
month :: CronSchedule -> MonthSpec
dayOfWeek :: CronSchedule -> DayOfWeekSpec
minute :: MinuteSpec
hour :: HourSpec
dayOfMonth :: DayOfMonthSpec
month :: MonthSpec
dayOfWeek :: DayOfWeekSpec
..} = do
  Expanded
expanded <- NonEmpty Int
-> NonEmpty Int
-> NonEmpty Int
-> NonEmpty Int
-> NonEmpty Int
-> Expanded
Expanded (NonEmpty Int
 -> NonEmpty Int
 -> NonEmpty Int
 -> NonEmpty Int
 -> NonEmpty Int
 -> Expanded)
-> Maybe (NonEmpty Int)
-> Maybe
     (NonEmpty Int
      -> NonEmpty Int -> NonEmpty Int -> NonEmpty Int -> Expanded)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Maybe (NonEmpty Int)
minF'
                       Maybe
  (NonEmpty Int
   -> NonEmpty Int -> NonEmpty Int -> NonEmpty Int -> Expanded)
-> Maybe (NonEmpty Int)
-> Maybe (NonEmpty Int -> NonEmpty Int -> NonEmpty Int -> Expanded)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (NonEmpty Int)
hourF'
                       Maybe (NonEmpty Int -> NonEmpty Int -> NonEmpty Int -> Expanded)
-> Maybe (NonEmpty Int)
-> Maybe (NonEmpty Int -> NonEmpty Int -> Expanded)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (NonEmpty Int)
domF'
                       Maybe (NonEmpty Int -> NonEmpty Int -> Expanded)
-> Maybe (NonEmpty Int) -> Maybe (NonEmpty Int -> Expanded)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (NonEmpty Int)
monthF'
                       Maybe (NonEmpty Int -> Expanded)
-> Maybe (NonEmpty Int) -> Maybe Expanded
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (NonEmpty Int)
dowF'
  if Expanded -> Bool
satisfiable Expanded
expanded
     then Expanded -> Maybe Expanded
forall a. a -> Maybe a
Just Expanded
expanded
     else Maybe Expanded
forall a. Maybe a
Nothing
  where
    minF' :: Maybe (NonEmpty Int)
minF' = (Int, Int) -> CronField -> Maybe (NonEmpty Int)
expandF (Int
0, Int
59) (MinuteSpec -> CronField
minuteSpec MinuteSpec
minute)
    hourF' :: Maybe (NonEmpty Int)
hourF' = (Int, Int) -> CronField -> Maybe (NonEmpty Int)
expandF (Int
0, Int
23) (HourSpec -> CronField
hourSpec HourSpec
hour)
    domF' :: Maybe (NonEmpty Int)
domF' = (Int, Int) -> CronField -> Maybe (NonEmpty Int)
expandF (Int
1, Int
31) (DayOfMonthSpec -> CronField
dayOfMonthSpec DayOfMonthSpec
dayOfMonth)
    monthF' :: Maybe (NonEmpty Int)
monthF' = (Int, Int) -> CronField -> Maybe (NonEmpty Int)
expandF (Int
1, Int
12) (MonthSpec -> CronField
monthSpec MonthSpec
month)
    dowF' :: Maybe (NonEmpty Int)
dowF' = NonEmpty Int -> NonEmpty Int
forall {a}. (Eq a, Num a) => NonEmpty a -> NonEmpty a
remapSunday (NonEmpty Int -> NonEmpty Int)
-> Maybe (NonEmpty Int) -> Maybe (NonEmpty Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> CronField -> Maybe (NonEmpty Int)
expandF (Int
0, Int
7) (DayOfWeekSpec -> CronField
dayOfWeekSpec DayOfWeekSpec
dayOfWeek)
    remapSunday :: NonEmpty a -> NonEmpty a
remapSunday NonEmpty a
lst = case (a -> Bool) -> NonEmpty a -> ([a], [a])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NE.partition (\a
n -> a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
|| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
7) NonEmpty a
lst of
                        ([], [a]
_)       -> NonEmpty a
lst
                        ([a]
_, [a]
noSunday) -> a
0 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
noSunday
    domRestricted :: Bool
domRestricted = CronField -> Bool
restricted (DayOfMonthSpec -> CronField
dayOfMonthSpec DayOfMonthSpec
dayOfMonth)
    dowRestricted :: Bool
dowRestricted = CronField -> Bool
restricted (DayOfWeekSpec -> CronField
dayOfWeekSpec 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 -> Bool
satisfiable Expanded {NonEmpty Int
minF :: Expanded -> NonEmpty Int
hourF :: Expanded -> NonEmpty Int
domF :: Expanded -> NonEmpty Int
monthF :: Expanded -> NonEmpty Int
dowF :: Expanded -> NonEmpty Int
minF :: NonEmpty Int
hourF :: NonEmpty Int
domF :: NonEmpty Int
monthF :: NonEmpty Int
dowF :: NonEmpty Int
..} = (Bool
domRestricted Bool -> Bool -> Bool
&& Bool
dowRestricted) Bool -> Bool -> Bool
||
      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Int -> NonEmpty Int -> Bool
hasValidForMonth Int
m NonEmpty Int
domF | Int
m <- (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FT.toList NonEmpty Int
monthF)]


-------------------------------------------------------------------------------
expandF :: (Int, Int) -> CronField -> Maybe EField
expandF :: (Int, Int) -> CronField -> Maybe (NonEmpty Int)
expandF (Int, Int)
rng (Field BaseField
f)       = (Int, Int) -> BaseField -> Maybe (NonEmpty Int)
expandBF (Int, Int)
rng BaseField
f
expandF (Int, Int)
rng (ListField NonEmpty BaseField
fs)  = NonEmpty Int -> NonEmpty Int
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (NonEmpty Int -> NonEmpty Int)
-> (NonEmpty (NonEmpty Int) -> NonEmpty Int)
-> NonEmpty (NonEmpty Int)
-> NonEmpty Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty Int) -> NonEmpty Int
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (NonEmpty Int) -> NonEmpty Int)
-> Maybe (NonEmpty (NonEmpty Int)) -> Maybe (NonEmpty Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BaseField -> Maybe (NonEmpty Int))
-> NonEmpty BaseField -> Maybe (NonEmpty (NonEmpty Int))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
FT.mapM ((Int, Int) -> BaseField -> Maybe (NonEmpty Int)
expandBF (Int, Int)
rng) NonEmpty BaseField
fs
expandF (Int, Int)
rng (StepField' StepField
sf) = (Int, Int) -> BaseField -> Int -> Maybe (NonEmpty Int)
expandBFStepped (Int, Int)
rng (StepField -> BaseField
sfField StepField
sf) (StepField -> Int
sfStepping StepField
sf)


-------------------------------------------------------------------------------
expandBFStepped :: (Int, Int) -> BaseField -> Int -> Maybe EField
expandBFStepped :: (Int, Int) -> BaseField -> Int -> Maybe (NonEmpty Int)
expandBFStepped (Int, Int)
rng BaseField
Star Int
step = [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ((Int, Int) -> Int -> [Int]
fillTo (Int, Int)
rng Int
step)
expandBFStepped (Int
_, Int
unitMax) (RangeField' RangeField
rf) Int
step = [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ((Int, Int) -> Int -> [Int]
fillTo (Int
start, Int
finish') Int
step)
  where
    finish' :: Int
finish' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
finish Int
unitMax
    start :: Int
start = RangeField -> Int
rfBegin RangeField
rf
    finish :: Int
finish = RangeField -> Int
rfEnd RangeField
rf
expandBFStepped (Int
_, Int
unitMax) (SpecificField' SpecificField
sf) Int
step =
  (Int, Int) -> BaseField -> Int -> Maybe (NonEmpty Int)
expandBFStepped (Int
startAt, Int
unitMax) BaseField
Star Int
step
  where
    startAt :: Int
startAt = SpecificField -> Int
specificField SpecificField
sf


-------------------------------------------------------------------------------
fillTo :: (Int, Int)
       -> Int
       -> [Int]
fillTo :: (Int, Int) -> Int -> [Int]
fillTo (Int
start, Int
finish) Int
step
  | Int
step Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0      = []
  | Int
finish Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
start = []
  | Bool
otherwise      = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
finish) [Int]
nums
  where
    nums :: [Int]
nums = [ Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
iter) | Int
iter <- [Int
0..]]


-------------------------------------------------------------------------------
expandBF :: (Int, Int) -> BaseField -> Maybe EField
expandBF :: (Int, Int) -> BaseField -> Maybe (NonEmpty Int)
expandBF (Int
lo, Int
hi) BaseField
Star         = NonEmpty Int -> Maybe (NonEmpty Int)
forall a. a -> Maybe a
Just ([Int] -> NonEmpty Int
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
lo Int
hi))
expandBF (Int, Int)
_ (SpecificField' SpecificField
sf) = NonEmpty Int -> Maybe (NonEmpty Int)
forall a. a -> Maybe a
Just (SpecificField -> Int
specificField SpecificField
sf Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [])
expandBF (Int, Int)
_ (RangeField' RangeField
rf)    = NonEmpty Int -> Maybe (NonEmpty Int)
forall a. a -> Maybe a
Just ([Int] -> NonEmpty Int
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo (RangeField -> Int
rfBegin RangeField
rf) (RangeField -> Int
rfEnd RangeField
rf)))


-------------------------------------------------------------------------------
validTODs :: EField -> EField -> [DiffTime]
validTODs :: NonEmpty Int -> NonEmpty Int -> [DiffTime]
validTODs NonEmpty Int
hrs NonEmpty Int
mns = [DiffTime]
dtSequence
  where
    minuteSequence :: [Int]
minuteSequence = (Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FT.toList NonEmpty Int
mns)
    hourSequence :: [Int]
hourSequence = (Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FT.toList NonEmpty Int
hrs)
    -- order here ensures we'll count up minutes before hours
    dtSequence :: [DiffTime]
dtSequence = [ Int -> Int -> DiffTime
todToDiffTime Int
hr Int
mn | Int
hr <- [Int]
hourSequence, Int
mn <- [Int]
minuteSequence]


-------------------------------------------------------------------------------
todToDiffTime :: Int -> Int -> DiffTime
todToDiffTime :: Int -> Int -> DiffTime
todToDiffTime Int
nextHour Int
nextMin = Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int
nextHour Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nextMin Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)


-------------------------------------------------------------------------------
timeOfDay :: DiffTime -> (Int, Int)
timeOfDay :: DiffTime -> (Int, Int)
timeOfDay DiffTime
t = (Int
h, Int
m)
  where
    seconds :: Int
seconds = DiffTime -> Int
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor DiffTime
t
    minutes :: Int
minutes = Int
seconds Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
60
    (Int
h, Int
m) = Int
minutes Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
60


-------------------------------------------------------------------------------
hasValidForMonth
    :: Int
    -- ^ Month
    -> EField
    -> Bool
hasValidForMonth :: Int -> NonEmpty Int -> Bool
hasValidForMonth Int
1 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
2 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
29
hasValidForMonth Int
3 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
4 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
30
hasValidForMonth Int
5 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
6 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
30
hasValidForMonth Int
7 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
8 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
9 NonEmpty Int
days  = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
30
hasValidForMonth Int
10 NonEmpty Int
days = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
11 NonEmpty Int
days = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
30
hasValidForMonth Int
12 NonEmpty Int
days = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
FT.minimum NonEmpty Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
hasValidForMonth Int
_ NonEmpty Int
_     = Bool
False


-------------------------------------------------------------------------------
data Expanded = Expanded {
     Expanded -> NonEmpty Int
minF   :: EField
   , Expanded -> NonEmpty Int
hourF  :: EField
   , Expanded -> NonEmpty Int
domF   :: EField
   , Expanded -> NonEmpty Int
monthF :: EField
   , Expanded -> NonEmpty Int
dowF   :: EField
   } deriving (Int -> Expanded -> ShowS
[Expanded] -> ShowS
Expanded -> String
(Int -> Expanded -> ShowS)
-> (Expanded -> String) -> ([Expanded] -> ShowS) -> Show Expanded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expanded -> ShowS
showsPrec :: Int -> Expanded -> ShowS
$cshow :: Expanded -> String
show :: Expanded -> String
$cshowList :: [Expanded] -> ShowS
showList :: [Expanded] -> ShowS
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 :: CronSchedule -> UTCTime -> Bool
scheduleMatches cs :: CronSchedule
cs@CronSchedule {DayOfWeekSpec
MonthSpec
DayOfMonthSpec
HourSpec
MinuteSpec
minute :: CronSchedule -> MinuteSpec
hour :: CronSchedule -> HourSpec
dayOfMonth :: CronSchedule -> DayOfMonthSpec
month :: CronSchedule -> MonthSpec
dayOfWeek :: CronSchedule -> DayOfWeekSpec
minute :: MinuteSpec
hour :: HourSpec
dayOfMonth :: DayOfMonthSpec
month :: MonthSpec
dayOfWeek :: DayOfWeekSpec
..} (UTCTime Day
d DiffTime
t) =
  Bool -> (Expanded -> Bool) -> Maybe Expanded -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Expanded -> Bool
go (CronSchedule -> Maybe Expanded
expand CronSchedule
cs)
  where
    go :: Expanded -> Bool
go Expanded {NonEmpty Int
minF :: Expanded -> NonEmpty Int
hourF :: Expanded -> NonEmpty Int
domF :: Expanded -> NonEmpty Int
monthF :: Expanded -> NonEmpty Int
dowF :: Expanded -> NonEmpty Int
minF :: NonEmpty Int
hourF :: NonEmpty Int
domF :: NonEmpty Int
monthF :: NonEmpty Int
dowF :: NonEmpty Int
..} = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
      [ Int -> NonEmpty Int -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
FT.elem Int
mn NonEmpty Int
minF
      , Int -> NonEmpty Int -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
FT.elem Int
hr NonEmpty Int
hourF
      , Int -> NonEmpty Int -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
FT.elem Int
mth NonEmpty Int
monthF
      , Bool
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 :: Bool
checkDOMAndDOW
          | CronField -> Bool
restricted (DayOfMonthSpec -> CronField
dayOfMonthSpec DayOfMonthSpec
dayOfMonth) Bool -> Bool -> Bool
&& CronField -> Bool
restricted (DayOfWeekSpec -> CronField
dayOfWeekSpec DayOfWeekSpec
dayOfWeek) =
              Bool
domMatches Bool -> Bool -> Bool
|| Bool
dowMatches
          | Bool
otherwise = Bool
domMatches Bool -> Bool -> Bool
&& Bool
dowMatches
        domMatches :: Bool
domMatches = Int -> NonEmpty Int -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
FT.elem Int
dom NonEmpty Int
domF
        dowMatches :: Bool
dowMatches = Int -> NonEmpty Int -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
FT.elem Int
dow NonEmpty Int
dowF
    (Year
_, Int
mth, Int
dom) = Day -> (Year, Int, Int)
toGregorian Day
d
    (Int
hr, Int
mn) = DiffTime -> (Int, Int)
timeOfDay DiffTime
t
    dow :: Int
dow = Day -> Int
getDOW Day
d


restricted :: CronField -> Bool
restricted :: CronField -> Bool
restricted = Bool -> Bool
not (Bool -> Bool) -> (CronField -> Bool) -> CronField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CronField -> Bool
isStar

isStar :: CronField -> Bool
isStar :: CronField -> Bool
isStar (Field BaseField
Star)    = Bool
True
isStar (ListField NonEmpty BaseField
bfs) = (BaseField -> Bool) -> NonEmpty BaseField -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
FT.any (BaseField -> BaseField -> Bool
forall a. Eq a => a -> a -> Bool
== BaseField
Star) NonEmpty BaseField
bfs
isStar (StepField' StepField
sf) = StepField -> BaseField
sfField StepField
sf BaseField -> BaseField -> Bool
forall a. Eq a => a -> a -> Bool
== BaseField
Star Bool -> Bool -> Bool
&& StepField -> Int
sfStepping StepField
sf Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
isStar CronField
_               = Bool
False