summaryrefslogtreecommitdiff
path: root/Utility/Scheduled.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-10-15 13:05:41 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-10-15 13:27:21 -0400
commite2d0b744e1588964e310482ac84aff3f1bea6b5e (patch)
treea87c22e580d404a74ec7538306042c2c01728a99 /Utility/Scheduled.hs
parent23d762b3da197d2e438c565a40b1660859a84bbb (diff)
add support for weekly, monthly, and yearly schedules that run on no specific day
Diffstat (limited to 'Utility/Scheduled.hs')
-rw-r--r--Utility/Scheduled.hs195
1 files changed, 133 insertions, 62 deletions
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index e759ecef4..ce655b356 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -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)
+
+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
- maxyday = 366 -- with leap days
- maxwnum = 53 -- some years have more than 52
- maxmday = 31
- maxmnum = 12
- maxwday = 7
+{- 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