fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix modular behaviour of cron

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-10 13:18:33 +02:00
parent 62bfc47d8c
commit ee08b641bb
1 changed files with 32 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
src/Cron.hs
View File

@ -117,40 +117,41 @@ listToMatch :: [a] -> CronNextMatch a
listToMatch [] = MatchNone listToMatch [] = MatchNone
listToMatch (t:_) = MatchAt t listToMatch (t:_) = MatchAt t
genMatch :: Int -- ^ Period genMatch :: Int -- ^ Period
-> Bool -- ^ Modular
-> Natural -- ^ Start value -> Natural -- ^ Start value
-> CronMatch -> CronMatch
-> [Natural] -> [Natural]
genMatch p st CronMatchAny = take p [st..] genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
genMatch _ _ CronMatchNone = [] genMatch _ _ _ CronMatchNone = []
genMatch p _ (CronMatchSome set) = take p . Set.toAscList $ toNullable set genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set
genMatch p st (CronMatchStep step) = do genMatch p m st (CronMatchStep step) = do
start <- [st..st + step] start <- [st..st + step]
guard $ (start `mod` step) == 0 guard $ (start `mod` step) == 0
take (ceiling $ fromIntegral p % step) [start,start + step..] take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
genMatch p st (CronMatchContiguous from to) = take p $ [max st from..to] 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 _ _ (CronMatchIntersect _ CronMatchNone) = [] genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
genMatch p st (CronMatchIntersect CronMatchAny other) = genMatch p st other genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
genMatch p st (CronMatchIntersect other CronMatchAny) = genMatch p st other genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
genMatch p st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2)) genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
= genMatch p st . CronMatchStep $ lcm st1 st2 = genMatch p m st . CronMatchStep $ lcm st1 st2
genMatch p st (CronMatchIntersect aGen bGen) genMatch p m st (CronMatchIntersect aGen bGen)
| [] <- as' = [] | [] <- as' = []
| (a:as) <- as' = mergeAnd (a:as) (genMatch p a bGen) | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
where where
as' = genMatch p st aGen as' = genMatch p m st aGen
mergeAnd [] _ = [] mergeAnd [] _ = []
mergeAnd _ [] = [] mergeAnd _ [] = []
mergeAnd (a:as) (b:bs) mergeAnd (a:as) (b:bs)
| a < b = mergeAnd as (b:bs) | a < b = mergeAnd as (b:bs)
| a == b = a : mergeAnd as bs | a == b = a : mergeAnd as bs
| a > b = mergeAnd (a:as) bs | a > b = mergeAnd (a:as) bs
genMatch p st (CronMatchUnion CronMatchNone other) = genMatch p st other genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
genMatch p st (CronMatchUnion other CronMatchNone) = genMatch p st other genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
genMatch p st (CronMatchUnion CronMatchAny _) = genMatch p st CronMatchAny genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
genMatch p st (CronMatchUnion _ CronMatchAny) = genMatch p st CronMatchAny genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
genMatch p st (CronMatchUnion aGen bGen) = merge (genMatch p st aGen) (genMatch p st bGen) genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
where where
merge [] bs = bs merge [] bs = bs
merge as [] = as merge as [] = as
@ -188,16 +189,16 @@ nextCronMatch tz mPrev now c@Cron{..}
| otherwise -> MatchNone | otherwise -> MatchNone
CronCalendar{..} -> listToMatch $ do CronCalendar{..} -> listToMatch $ do
let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
cronYear <- genMatch 400 cdYear cronYear cronYear <- genMatch 400 False cdYear cronYear
cronWeekOfYear <- genMatch 53 cdWeekOfYear cronWeekOfYear cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
cronDayOfYear <- genMatch 366 cdDayOfYear cronDayOfYear cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
cronMonth <- genMatch 12 cdMonth cronMonth cronMonth <- genMatch 12 True cdMonth cronMonth
cronWeekOfMonth <- genMatch 5 cdWeekOfMonth cronWeekOfMonth cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
cronDayOfMonth <- genMatch 31 cdDayOfMonth cronDayOfMonth cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
cronDayOfWeek <- genMatch 7 cdDayOfWeek cronDayOfWeek cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
cronHour <- genMatch 24 cdHour cronHour cronHour <- genMatch 24 True cdHour cronHour
cronMinute <- genMatch 60 cdMinute cronMinute cronMinute <- genMatch 60 True cdMinute cronMinute
cronSecond <- genMatch 60 cdSecond cronSecond cronSecond <- genMatch 60 True cdSecond cronSecond
guard $ consistentCronDate CronDate{..} guard $ consistentCronDate CronDate{..}
localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)