add support for weekly, monthly, and yearly schedules that run on no specific day
This commit is contained in:
Joey Hess
parent
7b82f431ba
commit
e5e4b80b09
3 changed files with 145 additions and 80 deletions
|
|
@ -38,9 +38,9 @@ data Schedule = Schedule Recurrance ScheduledTime
|
|||
|
||||
data Recurrance
|
||||
= Daily
|
||||
| Weekly WeekDay
|
||||
| Monthly MonthDay
|
||||
| Yearly YearDay
|
||||
| Weekly (Maybe WeekDay)
|
||||
| Monthly (Maybe MonthDay)
|
||||
| Yearly (Maybe YearDay)
|
||||
-- Days, Weeks, or Months of the year evenly divisible by a number.
|
||||
-- (Divisible Year is years evenly divisible by a number.)
|
||||
| Divisible Int Recurrance
|
||||
|
|
@ -65,6 +65,10 @@ data NextTime
|
|||
| NextTimeWindow LocalTime LocalTime
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
startTime :: NextTime -> LocalTime
|
||||
startTime (NextTimeExactly t) = t
|
||||
startTime (NextTimeWindow t _) = t
|
||||
|
||||
nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
|
||||
nextTime schedule lasttime = do
|
||||
now <- getCurrentTime
|
||||
|
|
@ -76,77 +80,127 @@ nextTime schedule lasttime = do
|
|||
calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
|
||||
calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime
|
||||
| scheduledtime == AnyTime = do
|
||||
start <- findfromtoday True
|
||||
return $ NextTimeWindow
|
||||
start
|
||||
(LocalTime (localDay start) (TimeOfDay 23 59 0))
|
||||
| otherwise = NextTimeExactly <$> findfromtoday False
|
||||
next <- findfromtoday True
|
||||
return $ case next of
|
||||
NextTimeWindow _ _ -> next
|
||||
NextTimeExactly t -> window (localDay t) (localDay t)
|
||||
| otherwise = NextTimeExactly . startTime <$> findfromtoday False
|
||||
where
|
||||
findfromtoday anytime =
|
||||
LocalTime <$> nextday <*> pure nexttime
|
||||
findfromtoday anytime = findfrom recurrance afterday today
|
||||
where
|
||||
nextday = findnextday recurrance afterday today
|
||||
today = localDay currenttime
|
||||
afterday = sameaslastday || toolatetoday
|
||||
toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
|
||||
sameaslastday = (localDay <$> lasttime) == Just today
|
||||
sameaslastday = lastday == Just today
|
||||
lastday = localDay <$> lasttime
|
||||
nexttime = case scheduledtime of
|
||||
AnyTime -> TimeOfDay 0 0 0
|
||||
SpecificTime h m -> TimeOfDay h m 0
|
||||
findnextday r afterday day = case r of
|
||||
exactly d = NextTimeExactly $ LocalTime d nexttime
|
||||
window startd endd = NextTimeWindow
|
||||
(LocalTime startd nexttime)
|
||||
(LocalTime endd (TimeOfDay 23 59 0))
|
||||
findfrom r afterday day = case r of
|
||||
Daily
|
||||
| afterday -> Just $ addDays 1 day
|
||||
| otherwise -> Just day
|
||||
Weekly w
|
||||
| afterday -> Just $ exactly $ addDays 1 day
|
||||
| otherwise -> Just $ exactly day
|
||||
Weekly Nothing
|
||||
| afterday -> skip 1
|
||||
| otherwise -> case (wday <$> lastday, wday day) of
|
||||
(Nothing, _) -> Just $ window day (addDays 6 day)
|
||||
(Just old, curr)
|
||||
| old == curr -> Just $ window day (addDays 6 day)
|
||||
| otherwise -> skip 1
|
||||
Monthly Nothing
|
||||
| afterday -> skip 1
|
||||
| maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->
|
||||
-- Window only covers current month,
|
||||
-- in case there is a Divisible requirement.
|
||||
Just $ window day (endOfMonth day)
|
||||
| otherwise -> skip 1
|
||||
Yearly Nothing
|
||||
| afterday -> skip 1
|
||||
| maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->
|
||||
Just $ window day (endOfYear day)
|
||||
| otherwise -> skip 1
|
||||
Weekly (Just w)
|
||||
| w < 0 || w > maxwday -> Nothing
|
||||
| w == wday day -> if afterday
|
||||
then Just $ addDays 7 day
|
||||
else Just day
|
||||
| otherwise -> Just $
|
||||
then Just $ exactly $ addDays 7 day
|
||||
else Just $ exactly day
|
||||
| otherwise -> Just $ exactly $
|
||||
addDays (fromIntegral $ (w - wday day) `mod` 7) day
|
||||
Monthly m
|
||||
Monthly (Just m)
|
||||
| m < 0 || m > maxmday -> Nothing
|
||||
-- TODO can be done more efficiently than recursing
|
||||
| m == mday day -> if afterday
|
||||
then findnextday r False (addDays 1 day)
|
||||
else Just day
|
||||
| otherwise -> findnextday r False (addDays 1 day)
|
||||
Yearly y
|
||||
then skip 1
|
||||
else Just $ exactly day
|
||||
| otherwise -> skip 1
|
||||
Yearly (Just y)
|
||||
| y < 0 || y > maxyday -> Nothing
|
||||
| y == yday day -> if afterday
|
||||
then findnextday r False (addDays 365 day)
|
||||
else Just day
|
||||
| otherwise -> findnextday r False (addDays 1 day)
|
||||
then skip 365
|
||||
else Just $ exactly day
|
||||
| otherwise -> skip 1
|
||||
Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
|
||||
Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
|
||||
Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
|
||||
Divisible n r'@(Yearly _) -> handlediv n r' year Nothing
|
||||
Divisible _ r'@(Divisible _ _) -> findnextday r' afterday day
|
||||
Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
|
||||
Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day
|
||||
where
|
||||
skip n = findfrom r False (addDays n day)
|
||||
handlediv n r' getval mmax
|
||||
| n > 0 && maybe True (n <=) mmax =
|
||||
findnextdaywhere r' (divisible n . getval) afterday day
|
||||
findfromwhere r' (divisible n . getval) afterday day
|
||||
| otherwise = Nothing
|
||||
findnextdaywhere r p afterday day
|
||||
| maybe True p d = d
|
||||
| otherwise = maybe d (findnextdaywhere r p True) d
|
||||
findfromwhere r p afterday day
|
||||
| maybe True (p . getday) next = next
|
||||
| otherwise = maybe Nothing (findfromwhere r p True . getday) next
|
||||
where
|
||||
d = findnextday r afterday day
|
||||
next = findfrom r afterday day
|
||||
getday = localDay . startTime
|
||||
divisible n v = v `rem` n == 0
|
||||
|
||||
-- extracting various quantities from a Day
|
||||
wday = thd3 . toWeekDate
|
||||
wnum = snd3 . toWeekDate
|
||||
mday = thd3 . toGregorian
|
||||
mnum = snd3 . toGregorian
|
||||
yday = snd . toOrdinalDate
|
||||
year = fromIntegral . fst . toOrdinalDate
|
||||
endOfMonth :: Day -> Day
|
||||
endOfMonth day =
|
||||
let (y,m,_d) = toGregorian day
|
||||
in fromGregorian y m (gregorianMonthLength y m)
|
||||
|
||||
maxyday = 366 -- with leap days
|
||||
maxwnum = 53 -- some years have more than 52
|
||||
maxmday = 31
|
||||
maxmnum = 12
|
||||
maxwday = 7
|
||||
endOfYear :: Day -> Day
|
||||
endOfYear day =
|
||||
let (y,_m,_d) = toGregorian day
|
||||
in endOfMonth (fromGregorian y maxmnum 1)
|
||||
|
||||
-- extracting various quantities from a Day
|
||||
wday :: Day -> Int
|
||||
wday = thd3 . toWeekDate
|
||||
wnum :: Day -> Int
|
||||
wnum = snd3 . toWeekDate
|
||||
mday :: Day -> Int
|
||||
mday = thd3 . toGregorian
|
||||
mnum :: Day -> Int
|
||||
mnum = snd3 . toGregorian
|
||||
yday :: Day -> Int
|
||||
yday = snd . toOrdinalDate
|
||||
ynum :: Day -> Int
|
||||
ynum = fromIntegral . fst . toOrdinalDate
|
||||
|
||||
{- Calendar max and mins. -}
|
||||
maxyday :: Int
|
||||
maxyday = 366 -- with leap days
|
||||
minyday :: Int
|
||||
minyday = 365
|
||||
maxwnum :: Int
|
||||
maxwnum = 53 -- some years have more than 52
|
||||
maxmday :: Int
|
||||
maxmday = 31
|
||||
minmday :: Int
|
||||
minmday = 28
|
||||
maxmnum :: Int
|
||||
maxmnum = 12
|
||||
maxwday :: Int
|
||||
maxwday = 7
|
||||
|
||||
fromRecurrance :: Recurrance -> String
|
||||
fromRecurrance (Divisible n r) =
|
||||
|
|
@ -160,28 +214,40 @@ fromRecurrance' a (Monthly n) = onday n (a "month")
|
|||
fromRecurrance' a (Yearly n) = onday n (a "year")
|
||||
fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
|
||||
|
||||
onday :: Int -> String -> String
|
||||
onday n s = "on day " ++ show n ++ " of " ++ s
|
||||
onday :: Maybe Int -> String -> String
|
||||
onday (Just n) s = "on day " ++ show n ++ " of " ++ s
|
||||
onday Nothing s = s
|
||||
|
||||
toRecurrance :: String -> Maybe Recurrance
|
||||
toRecurrance s = case words s of
|
||||
("every":"day":[]) -> Just Daily
|
||||
("on":"day":sd:"of":"every":something:[]) -> parse something sd
|
||||
("on":"day":sd:"of":"every":something:[]) -> withday sd something
|
||||
("every":something:[]) -> noday something
|
||||
("days":"divisible":"by":sn:[]) ->
|
||||
Divisible <$> getdivisor sn <*> pure Daily
|
||||
("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
|
||||
Divisible
|
||||
<$> getdivisor sn
|
||||
<*> parse something sd
|
||||
<*> withday sd something
|
||||
("every":something:"divisible":"by":sn:[]) ->
|
||||
Divisible
|
||||
<$> getdivisor sn
|
||||
<*> noday something
|
||||
_ -> Nothing
|
||||
where
|
||||
parse "week" sd = withday Weekly sd
|
||||
parse "month" sd = withday Monthly sd
|
||||
parse "year" sd = withday Yearly sd
|
||||
parse v sd
|
||||
| "s" `isSuffixOf` v = parse (reverse $ drop 1 $ reverse v) sd
|
||||
constructor "week" = Just Weekly
|
||||
constructor "month" = Just Monthly
|
||||
constructor "year" = Just Yearly
|
||||
constructor u
|
||||
| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
|
||||
| otherwise = Nothing
|
||||
withday c sd = c <$> readish sd
|
||||
withday sd u = do
|
||||
c <- constructor u
|
||||
d <- readish sd
|
||||
Just $ c (Just d)
|
||||
noday u = do
|
||||
c <- constructor u
|
||||
Just $ c Nothing
|
||||
getdivisor sn = do
|
||||
n <- readish sn
|
||||
if n > 0
|
||||
|
|
@ -255,18 +321,23 @@ instance Arbitrary ScheduledTime where
|
|||
instance Arbitrary Recurrance where
|
||||
arbitrary = oneof
|
||||
[ pure Daily
|
||||
, Weekly <$> nonNegative arbitrary
|
||||
, Monthly <$> nonNegative arbitrary
|
||||
, Yearly <$> nonNegative arbitrary
|
||||
, Weekly <$> arbday
|
||||
, Monthly <$> arbday
|
||||
, Yearly <$> arbday
|
||||
, Divisible
|
||||
<$> positive arbitrary
|
||||
<*> oneof -- no nested Divisibles
|
||||
[ pure Daily
|
||||
, Weekly <$> nonNegative arbitrary
|
||||
, Monthly <$> nonNegative arbitrary
|
||||
, Yearly <$> nonNegative arbitrary
|
||||
, Weekly <$> arbday
|
||||
, Monthly <$> arbday
|
||||
, Yearly <$> arbday
|
||||
]
|
||||
]
|
||||
where
|
||||
arbday = oneof
|
||||
[ Just <$> nonNegative arbitrary
|
||||
, pure Nothing
|
||||
]
|
||||
|
||||
prop_schedule_roundtrips :: Schedule -> Bool
|
||||
prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue