summaryrefslogtreecommitdiff
path: root/Utility/Scheduled.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-10-07 23:02:47 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-10-07 23:13:30 -0400
commit38d043ec1ad2aa100c46b98c298163a9d3753ee1 (patch)
treedb3aeeff1f8761000853cbe03f78cdc5c8942782 /Utility/Scheduled.hs
parent1e5ed2e58e5d4c2a9caeb4e3676b33c70f60e714 (diff)
calculating the next time on a Schedule
Wow! This was hairy, but about 10x less hairy than expected actually! A bit more recursion than I really like, since I think in theory all of this date stuff can be calulated using some formulas I am too lazy too look up. But this doesn't matter in practice; I asked it for nextTime (Schedule (Divisible 100 (Yearly 7)) (SpecificTime 23 59) (MinutesDuration 10)) Nothing .. and it calculated (NextTimeExactly 2100-01-07 23:59:00) in milliseconds.
Diffstat (limited to 'Utility/Scheduled.hs')
-rw-r--r--Utility/Scheduled.hs149
1 files changed, 128 insertions, 21 deletions
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index 2b771a9b5..2c8663339 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -8,8 +8,9 @@
module Utility.Scheduled (
Schedule(..),
Recurrance(..),
- TimeOfDay(..),
+ ScheduledTime(..),
Duration(..),
+ nextTime,
fromSchedule,
toSchedule,
parseSchedule,
@@ -19,8 +20,15 @@ module Utility.Scheduled (
import Common
import Utility.QuickCheck
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.OrdinalDate
+import Data.Tuple.Utils
+
{- Some sort of scheduled event. -}
-data Schedule = Schedule Recurrance TimeOfDay Duration
+data Schedule = Schedule Recurrance ScheduledTime Duration
deriving (Eq, Show, Ord)
data Recurrance
@@ -28,14 +36,16 @@ data Recurrance
| Weekly WeekDay
| Monthly MonthDay
| Yearly YearDay
- | Divisable Int Recurrance
+ -- Days, Weeks, or Months of the year evenly divisible by a number.
+ -- (Divisible Year is years evenly divisible by a number.)
+ | Divisible Int Recurrance
deriving (Eq, Show, Ord)
type WeekDay = Int
type MonthDay = Int
type YearDay = Int
-data TimeOfDay
+data ScheduledTime
= AnyTime
| SpecificTime Hour Minute
deriving (Eq, Show, Ord)
@@ -46,8 +56,105 @@ type Minute = Int
data Duration = MinutesDuration Int
deriving (Eq, Show, Ord)
+{- Next time a Schedule should take effect. The NextTimeWindow is used
+ - when a Schedule is allowed to start at some point within the window. -}
+data NextTime
+ = NextTimeExactly LocalTime
+ | NextTimeWindow LocalTime LocalTime
+ deriving (Eq, Show)
+
+nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
+nextTime schedule lasttime = do
+ now <- getCurrentTime
+ tz <- getTimeZone now
+ return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
+
+{- Calculate the next time that fits a Schedule, based on the
+ - last time it occurred, and the current time. -}
+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
+calcNextTime (Schedule recurrance scheduledtime _duration) lasttime currenttime
+ | scheduledtime == AnyTime = do
+ start <- findfromtoday
+ return $ NextTimeWindow
+ start
+ (LocalTime (localDay start) (TimeOfDay 23 59 0))
+ | otherwise = NextTimeExactly <$> findfromtoday
+ where
+ findfromtoday =
+ LocalTime <$> nextday <*> pure nexttime
+ where
+ nextday = findnextday recurrance afterday today
+ today = localDay currenttime
+ afterday = sameaslastday || toolatetoday
+ toolatetoday = localTimeOfDay currenttime >= nexttime
+ sameaslastday = (localDay <$> lasttime) == Just today
+ nexttime = case scheduledtime of
+ AnyTime -> TimeOfDay 0 0 0
+ SpecificTime h m -> TimeOfDay h m 0
+ findnextday r afterday day = case r of
+ Daily
+ | afterday -> Just $ addDays 1 day
+ | otherwise -> Just day
+ Weekly w
+ | w < 0 || w > maxwday -> Nothing
+ | w == wday day -> if afterday
+ then Just $ addDays 7 day
+ else Just day
+ | otherwise -> Just $
+ addDays (fromIntegral $ (w - wday day) `mod` 7) day
+ Monthly 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
+ | 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)
+ Divisible n r'@Daily
+ | n > 0 && n <= maxyday ->
+ findnextdaywhere r' (divisible n . yday) afterday day
+ | otherwise -> Nothing
+ Divisible n r'@(Weekly _)
+ | n > 0 && n <= maxwnum ->
+ findnextdaywhere r' (divisible n . wnum) afterday day
+ | otherwise -> Nothing
+ Divisible n r'@(Monthly _)
+ | n > 0 && n <= maxmnum ->
+ findnextdaywhere r' (divisible n . mnum) afterday day
+ | otherwise -> Nothing
+ Divisible n r'@(Yearly _)
+ | n > 0 ->
+ findnextdaywhere r' (divisible n . year) afterday day
+ | otherwise -> Nothing
+ Divisible _ r'@(Divisible _ _) -> findnextday r' afterday day
+ findnextdaywhere r p afterday day
+ | maybe True p d = d
+ | otherwise = maybe d (findnextdaywhere r p True) d
+ where
+ d = findnextday r afterday day
+ 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
+
+ maxyday = 366 -- with leap days
+ maxwnum = 53 -- some years have more than 53
+ maxmday = 31
+ maxmnum = 12
+ maxwday = 7
+
fromRecurrance :: Recurrance -> String
-fromRecurrance (Divisable n r) =
+fromRecurrance (Divisible n r) =
fromRecurrance' (++ "s divisible by " ++ show n) r
fromRecurrance r = fromRecurrance' ("every " ++) r
@@ -56,7 +163,7 @@ fromRecurrance' a Daily = a "day"
fromRecurrance' a (Weekly n) = onday n (a "week")
fromRecurrance' a (Monthly n) = onday n (a "month")
fromRecurrance' a (Yearly n) = onday n (a "year")
-fromRecurrance' a (Divisable _n r) = fromRecurrance' a r -- not used
+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
onday :: Int -> String -> String
onday n s = "on day " ++ show n ++ " of " ++ s
@@ -66,9 +173,9 @@ toRecurrance s = case words s of
("every":"day":[]) -> Just Daily
("on":"day":sd:"of":"every":something:[]) -> parse something sd
("days":"divisible":"by":sn:[]) ->
- Divisable <$> getdivisor sn <*> pure Daily
+ Divisible <$> getdivisor sn <*> pure Daily
("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
- Divisable
+ Divisible
<$> getdivisor sn
<*> parse something sd
_ -> Nothing
@@ -86,13 +193,13 @@ toRecurrance s = case words s of
then Just n
else Nothing
-fromTimeOfDay :: TimeOfDay -> String
-fromTimeOfDay AnyTime = "any time"
-fromTimeOfDay (SpecificTime h m) = show h ++ ":" ++ show m
+fromScheduledTime :: ScheduledTime -> String
+fromScheduledTime AnyTime = "any time"
+fromScheduledTime (SpecificTime h m) = show h ++ ":" ++ show m
-toTimeOfDay :: String -> Maybe TimeOfDay
-toTimeOfDay "any time" = Just AnyTime
-toTimeOfDay s =
+toScheduledTime :: String -> Maybe ScheduledTime
+toScheduledTime "any time" = Just AnyTime
+toScheduledTime s =
let (h, m) = separate (== ':') s
in SpecificTime <$> readish h <*> readish m
@@ -106,10 +213,10 @@ toDuration s = case words s of
_ -> Nothing
fromSchedule :: Schedule -> String
-fromSchedule (Schedule recurrance timeofday duration) = unwords
+fromSchedule (Schedule recurrance scheduledtime duration) = unwords
[ fromRecurrance recurrance
, "at"
- , fromTimeOfDay timeofday
+ , fromScheduledTime scheduledtime
, "for"
, fromDuration duration
]
@@ -121,8 +228,8 @@ parseSchedule :: String -> Either String Schedule
parseSchedule s = do
r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
(toRecurrance recurrance)
- t <- maybe (Left $ "bad time of day: " ++ timeofday) Right
- (toTimeOfDay timeofday)
+ t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
+ (toScheduledTime scheduledtime)
d <- maybe (Left $ "bad duration: " ++ duration) Right
(toDuration duration)
Right $ Schedule r t d
@@ -131,7 +238,7 @@ parseSchedule s = do
(rws, ws') = separate (== "at") ws
(tws, dws) = separate (== "for") ws'
recurrance = unwords rws
- timeofday = unwords tws
+ scheduledtime = unwords tws
duration = unwords dws
instance Arbitrary Schedule where
@@ -140,7 +247,7 @@ instance Arbitrary Schedule where
instance Arbitrary Duration where
arbitrary = MinutesDuration <$> nonNegative arbitrary
-instance Arbitrary TimeOfDay where
+instance Arbitrary ScheduledTime where
arbitrary = oneof
[ pure AnyTime
, SpecificTime
@@ -154,7 +261,7 @@ instance Arbitrary Recurrance where
, Weekly <$> nonNegative arbitrary
, Monthly <$> nonNegative arbitrary
, Yearly <$> nonNegative arbitrary
- , Divisable
+ , Divisible
<$> positive arbitrary
<*> oneof -- no nested Divisibles
[ pure Daily