255 lines
9.9 KiB
Haskell
255 lines
9.9 KiB
Haskell
module Cron
|
|
( evalCronMatch
|
|
, CronNextMatch(..)
|
|
, nextCronMatch
|
|
, module Cron.Types
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
import Prelude (lcm)
|
|
import Cron.Types
|
|
|
|
import Data.Time
|
|
import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid)
|
|
import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid)
|
|
import Data.Time.Zones
|
|
|
|
import Numeric.Natural
|
|
import Data.Ratio ((%))
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Utils.Lens hiding (from, to)
|
|
|
|
|
|
data CronDate = CronDate
|
|
{ cdYear, cdWeekOfYear, cdDayOfYear
|
|
, cdMonth, cdWeekOfMonth, cdDayOfMonth
|
|
, cdDayOfWeek
|
|
, cdHour, cdMinute, cdSecond :: Natural
|
|
} deriving (Eq, Show, Read)
|
|
|
|
makeLenses_ ''CronDate
|
|
|
|
|
|
evalCronMatch :: CronMatch -> Natural -> Bool
|
|
evalCronMatch CronMatchAny _ = True
|
|
evalCronMatch CronMatchNone _ = False
|
|
evalCronMatch (CronMatchSome xs) x = Set.member x $ toNullable xs
|
|
evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0
|
|
evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to
|
|
evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x
|
|
evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x
|
|
|
|
toCronDate :: LocalTime -> CronDate
|
|
toCronDate LocalTime{..} = CronDate{..}
|
|
where
|
|
(fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth)
|
|
= toGregorian localDay
|
|
(_, fromIntegral -> cdDayOfYear)
|
|
= toOrdinalDate localDay
|
|
(_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
|
|
= toWeekDate localDay
|
|
cdWeekOfMonth = go 1 localDay
|
|
where
|
|
go :: Natural -> Day -> Natural
|
|
go n day
|
|
| dow /= 4 = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday
|
|
| m == m' = go (succ n) day'
|
|
| otherwise = n
|
|
where
|
|
(y, w, dow) = toWeekDate day
|
|
day'
|
|
| w /= 0 = fromWeekDate y (pred w) dow
|
|
| otherwise = fromWeekDate (pred y) 53 dow
|
|
(_, m, _) = toGregorian day
|
|
(_, m', _) = toGregorian day'
|
|
TimeOfDay
|
|
{ todHour = fromIntegral -> cdHour
|
|
, todMin = fromIntegral -> cdMinute
|
|
, todSec = round -> cdSecond
|
|
} = localTimeOfDay
|
|
|
|
consistentCronDate :: CronDate -> Bool
|
|
consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
|
|
gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
|
|
wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
|
|
guard $ gDay == wDay
|
|
oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
|
|
guard $ wDay == oDay
|
|
guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate"))
|
|
return True
|
|
|
|
|
|
data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
|
|
deriving (Eq, Ord, Show, Read, Functor)
|
|
|
|
instance Applicative CronNextMatch where
|
|
pure = MatchAt
|
|
_ <*> MatchNone = MatchNone
|
|
MatchNone <*> _ = MatchNone
|
|
_ <*> MatchAsap = MatchAsap
|
|
MatchAsap <*> _ = MatchAsap
|
|
MatchAt f <*> MatchAt x = MatchAt $ f x
|
|
|
|
instance Alternative CronNextMatch where
|
|
empty = MatchNone
|
|
x <|> MatchNone = x
|
|
MatchNone <|> x = x
|
|
_ <|> MatchAsap = MatchAsap
|
|
MatchAsap <|> _ = MatchAsap
|
|
(MatchAt a) <|> (MatchAt _) = MatchAt a
|
|
|
|
|
|
listToMatch :: [a] -> CronNextMatch a
|
|
listToMatch [] = MatchNone
|
|
listToMatch (t:_) = MatchAt t
|
|
|
|
genMatch :: Int -- ^ Period
|
|
-> Bool -- ^ Modular
|
|
-> Natural -- ^ Start value
|
|
-> CronMatch
|
|
-> [Natural]
|
|
genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
|
|
genMatch _ _ _ CronMatchNone = []
|
|
genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs
|
|
genMatch p m st (CronMatchStep step) = do
|
|
start <- [st..st + step]
|
|
guard $ (start `mod` step) == 0
|
|
take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
|
|
genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
|
|
genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
|
|
genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
|
|
genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
|
|
genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
|
|
genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
|
|
= genMatch p m st . CronMatchStep $ lcm st1 st2
|
|
genMatch p m st (CronMatchIntersect aGen bGen)
|
|
| [] <- as' = []
|
|
| (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
|
|
where
|
|
as' = genMatch p m st aGen
|
|
mergeAnd [] _ = []
|
|
mergeAnd _ [] = []
|
|
mergeAnd (a:as) (b:bs)
|
|
| a < b = mergeAnd as (b:bs)
|
|
| a == b = a : mergeAnd as bs
|
|
| otherwise = mergeAnd (a:as) bs
|
|
genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
|
|
genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
|
|
genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
|
|
genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
|
|
genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
|
|
where
|
|
merge [] bs = bs
|
|
merge as [] = as
|
|
merge (a:as) (b:bs)
|
|
| a < b = a : merge as (b:bs)
|
|
| a == b = a : merge as bs
|
|
| otherwise = b : merge (a:as) bs
|
|
|
|
nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
|
|
-> Maybe UTCTime -- ^ Time of last execution of the job
|
|
-> NominalDiffTime -- ^ Scheduling precision
|
|
-> UTCTime -- ^ Current time, used only for `CronCalendar`
|
|
-> Cron
|
|
-> CronNextMatch UTCTime
|
|
nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
|
|
MatchAsap -> MatchNone
|
|
MatchAt ts
|
|
| MatchAt ts' <- nextMatch
|
|
, ts' <= ts -> MatchAt ts'
|
|
| MatchAsap <- nextMatch
|
|
, now <= ts -> MatchAsap
|
|
| otherwise -> MatchNone
|
|
MatchNone -> nextMatch
|
|
where
|
|
notAfter
|
|
| Right c' <- cronNotAfter
|
|
, Just ref <- notAfterRef
|
|
= execRef' ref False c'
|
|
| Left diff <- cronNotAfter
|
|
, Just ref <- notAfterRef
|
|
= MatchAt $ diff `addUTCTime` ref
|
|
| otherwise = MatchNone
|
|
notAfterRef
|
|
| Just prevT <- mPrev = Just prevT
|
|
| otherwise = case execRef' now False cronInitial of
|
|
MatchAsap -> error "execRef' should not return MatchAsap"
|
|
MatchAt t -> Just t
|
|
MatchNone -> Nothing
|
|
nextMatch = case mPrev of
|
|
Nothing
|
|
-> execRef now False cronInitial
|
|
Just prevT
|
|
-> case cronRepeat of
|
|
CronRepeatOnChange
|
|
| not $ matchesCron tz Nothing prec 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
|
|
_other
|
|
-> execRef (addUTCTime cronRateLimit prevT) True cronNext
|
|
_other -> MatchNone
|
|
|
|
execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
|
|
MatchAt t
|
|
| t <= ref -> MatchAsap
|
|
other -> other
|
|
|
|
execRef' ref wasExecd cronAbsolute = case cronAbsolute of
|
|
CronAsap -> MatchAt ref
|
|
CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
|
|
| ref <= ts || not wasExecd -> MatchAt ts
|
|
| otherwise -> MatchNone
|
|
CronCalendar{..} -> listToMatch $ do
|
|
let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
|
|
|
|
mCronYear <- genMatch 400 False cdYear cronYear
|
|
mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
|
|
mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
|
|
mCronMonth <- genMatch 12 True cdMonth cronMonth
|
|
mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
|
|
mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
|
|
mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
|
|
mCronHour <- genMatch 24 True cdHour cronHour
|
|
mCronMinute <- genMatch 60 True cdMinute cronMinute
|
|
mCronSecond <- genMatch 60 True cdSecond cronSecond
|
|
guard $ consistentCronDate CronDate
|
|
{ cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth
|
|
, cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond
|
|
, cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
|
|
, cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek
|
|
}
|
|
|
|
localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
|
|
let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
|
|
return $ localTimeToUTCTZ tz LocalTime{..}
|
|
CronNotScheduled -> MatchNone
|
|
|
|
matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
|
|
-> Maybe UTCTime -- ^ Previous execution of the job
|
|
-> NominalDiffTime -- ^ Scheduling precision
|
|
-> 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 prec now cron = case nextCronMatch tz mPrev prec now cron of
|
|
MatchAsap -> True
|
|
MatchNone -> False
|
|
MatchAt ts -> ts <= addUTCTime prec now
|