210 lines
7.9 KiB
Haskell
210 lines
7.9 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, RecordWildCards
|
|
, PatternGuards
|
|
, ViewPatterns
|
|
, DeriveFunctor
|
|
, TemplateHaskell
|
|
, NamedFieldPuns
|
|
#-}
|
|
|
|
module Cron
|
|
( 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 Data.List.NonEmpty (NonEmpty(..))
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import Utils.Lens.TH
|
|
import Control.Lens
|
|
|
|
|
|
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 set) x = Set.member x $ toNullable set
|
|
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 set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set
|
|
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
|
|
| a > b = 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
|
|
| a > b = b : merge (a:as) bs
|
|
|
|
nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
|
|
-> Maybe UTCTime -- ^ Time of last execution of the job
|
|
-> UTCTime -- ^ Current time, used only for `CronCalendar`
|
|
-> Cron
|
|
-> CronNextMatch UTCTime
|
|
nextCronMatch tz mPrev now c@Cron{..}
|
|
| isNothing mPrev
|
|
= execRef now False cronInitial
|
|
| isJust mPrev
|
|
, isNothing cronRepeat
|
|
= MatchNone
|
|
| Just prevT <- mPrev
|
|
, Just CronPeriod{..} <- cronRepeat
|
|
= case cronNext of
|
|
CronAsap
|
|
| addUTCTime cronMinInterval prevT <= now
|
|
-> MatchAsap
|
|
| otherwise
|
|
-> MatchAt $ addUTCTime cronMinInterval prevT
|
|
CronNotScheduled
|
|
| CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } <- cronNext
|
|
, now <= ts -> MatchAt ts
|
|
cronNext -> execRef (addUTCTime cronMinInterval prevT) True cronNext
|
|
where
|
|
execRef ref wasExecd cronAbsolute = case cronAbsolute of
|
|
CronAsap -> MatchAsap
|
|
CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
|
|
| ref <= ts -> MatchAt ts
|
|
| not wasExecd -> MatchAsap
|
|
| otherwise -> MatchNone
|
|
CronCalendar{..} -> listToMatch $ do
|
|
let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
|
|
cronYear <- genMatch 400 False cdYear cronYear
|
|
cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
|
|
cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
|
|
cronMonth <- genMatch 12 True cdMonth cronMonth
|
|
cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
|
|
cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
|
|
cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
|
|
cronHour <- genMatch 24 True cdHour cronHour
|
|
cronMinute <- genMatch 60 True cdMinute cronMinute
|
|
cronSecond <- genMatch 60 True cdSecond cronSecond
|
|
guard $ consistentCronDate CronDate{..}
|
|
localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
|
|
let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)
|
|
return $ localTimeToUTCTZ tz LocalTime{..}
|
|
CronNotScheduled -> MatchNone
|