{- scheduled activities - - Copyright 2013-2014 Joey Hess - - License: BSD-2-clause -} module Utility.Scheduled ( Schedule(..), Recurrance(..), ScheduledTime(..), NextTime(..), WeekDay, MonthDay, YearDay, nextTime, calcNextTime, startTime, fromSchedule, fromScheduledTime, toScheduledTime, fromRecurrance, toRecurrance, toSchedule, parseSchedule, prop_past_sane, ) where import Utility.Data import Utility.PartialPrelude import Utility.Misc import Utility.Tuple import Utility.Split import Data.List import Data.Time.Clock import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate import Data.Time.Format () import Data.Char import Control.Applicative import Prelude {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime deriving (Eq, Read, Show, Ord) data Recurrance = Daily | Weekly (Maybe WeekDay) | Monthly (Maybe MonthDay) | Yearly (Maybe YearDay) | Divisible Int Recurrance -- ^ Days, Weeks, or Months of the year evenly divisible by a number. -- (Divisible Year is years evenly divisible by a number.) deriving (Eq, Read, Show, Ord) type WeekDay = Int type MonthDay = Int type YearDay = Int data ScheduledTime = AnyTime | SpecificTime Hour Minute deriving (Eq, Read, Show, Ord) type Hour = Int type Minute = Int -- | 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, 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 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@(Schedule recurrance scheduledtime) lasttime currenttime | scheduledtime == AnyTime = do next <- findfromtoday True return $ case next of NextTimeWindow _ _ -> next NextTimeExactly t -> window (localDay t) (localDay t) | otherwise = NextTimeExactly . startTime <$> findfromtoday False where findfromtoday anytime = findfrom recurrance afterday today where today = localDay currenttime afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime sameaslastrun = lastrun == Just today lastrun = localDay <$> lasttime nexttime = case scheduledtime of AnyTime -> TimeOfDay 0 0 0 SpecificTime h m -> TimeOfDay h m 0 exactly d = NextTimeExactly $ LocalTime d nexttime window startd endd = NextTimeWindow (LocalTime startd nexttime) (LocalTime endd (TimeOfDay 23 59 0)) findfrom r afterday candidate | ynum candidate > (ynum (localDay currenttime)) + 100 = -- avoid possible infinite recusion error $ "bug: calcNextTime did not find a time within 100 years to run " ++ show (schedule, lasttime, currenttime) | otherwise = findfromChecked r afterday candidate findfromChecked r afterday candidate = case r of Daily | afterday -> Just $ exactly $ addDays 1 candidate | otherwise -> Just $ exactly candidate Weekly Nothing | afterday -> skip 1 | otherwise -> case (wday <$> lastrun, wday candidate) of (Nothing, _) -> Just $ window candidate (addDays 6 candidate) (Just old, curr) | old == curr -> Just $ window candidate (addDays 6 candidate) | otherwise -> skip 1 Monthly Nothing | afterday -> skip 1 | maybe True (candidate `oneMonthPast`) lastrun -> Just $ window candidate (endOfMonth candidate) | otherwise -> skip 1 Yearly Nothing | afterday -> skip 1 | maybe True (candidate `oneYearPast`) lastrun -> Just $ window candidate (endOfYear candidate) | otherwise -> skip 1 Weekly (Just w) | w < 0 || w > maxwday -> Nothing | w == wday candidate -> if afterday then Just $ exactly $ addDays 7 candidate else Just $ exactly candidate | otherwise -> Just $ exactly $ addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate Monthly (Just m) | m < 0 || m > maxmday -> Nothing -- TODO can be done more efficiently than recursing | m == mday candidate -> if afterday then skip 1 else Just $ exactly candidate | otherwise -> skip 1 Yearly (Just y) | y < 0 || y > maxyday -> Nothing | y == yday candidate -> if afterday then skip 365 else Just $ exactly candidate | 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' ynum Nothing Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where skip n = findfrom r False (addDays n candidate) handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing findfromwhere r p afterday candidate | maybe True (p . getday) next = next | otherwise = maybe Nothing (findfromwhere r p True . getday) next where next = findfrom r afterday candidate getday = localDay . startTime divisible n v = v `rem` n == 0 -- Check if the new Day occurs one month or more past the old Day. oneMonthPast :: Day -> Day -> Bool new `oneMonthPast` old = fromGregorian y (m+1) d <= new where (y,m,d) = toGregorian old -- Check if the new Day occurs one year or more past the old Day. oneYearPast :: Day -> Day -> Bool new `oneYearPast` old = fromGregorian (y+1) m d <= new where (y,m,d) = toGregorian old 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 -- Calendar max values. maxyday :: Int maxyday = 366 -- with leap days maxwnum :: Int maxwnum = 53 -- some years have more than 52 maxmday :: Int maxmday = 31 maxmnum :: Int maxmnum = 12 maxwday :: Int maxwday = 7 fromRecurrance :: Recurrance -> String fromRecurrance (Divisible n r) = fromRecurrance' (++ "s divisible by " ++ show n) r fromRecurrance r = fromRecurrance' ("every " ++) r fromRecurrance' :: (String -> String) -> Recurrance -> String 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 (Divisible _n r) = fromRecurrance' a r -- not used 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:[]) -> 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 <*> withday sd something ("every":something:"divisible":"by":sn:[]) -> Divisible <$> getdivisor sn <*> noday something (something:"divisible":"by":sn:[]) -> Divisible <$> getdivisor sn <*> noday something _ -> Nothing where constructor "week" = Just Weekly constructor "month" = Just Monthly constructor "year" = Just Yearly constructor u | "s" `isSuffixOf` u = constructor $ dropFromEnd 1 u | otherwise = Nothing 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 then Just n else Nothing fromScheduledTime :: ScheduledTime -> String fromScheduledTime AnyTime = "any time" fromScheduledTime (SpecificTime h m) = show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm where pad n s = replicate (n - length s) '0' ++ s (h', ampm) | h == 0 = (12, "AM") | h < 12 = (h, "AM") | h == 12 = (h, "PM") | otherwise = (h - 12, "PM") toScheduledTime :: String -> Maybe ScheduledTime toScheduledTime "any time" = Just AnyTime toScheduledTime v = case words v of (s:ampm:[]) | map toUpper ampm == "AM" -> go s h0 | map toUpper ampm == "PM" -> go s (\h -> (h0 h) + 12) | otherwise -> Nothing (s:[]) -> go s id _ -> Nothing where h0 h | h == 12 = 0 | otherwise = h go :: String -> (Int -> Int) -> Maybe ScheduledTime go s adjust = let (h, m) = separate (== ':') s in SpecificTime <$> (adjust <$> readish h) <*> if null m then Just 0 else readish m fromSchedule :: Schedule -> String fromSchedule (Schedule recurrance scheduledtime) = unwords [ fromRecurrance recurrance , "at" , fromScheduledTime scheduledtime ] toSchedule :: String -> Maybe Schedule toSchedule = eitherToMaybe . parseSchedule parseSchedule :: String -> Either String Schedule parseSchedule s = do r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right (toRecurrance recurrance) t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right (toScheduledTime scheduledtime) Right $ Schedule r t where (rws, tws) = separate (== "at") (words s) recurrance = unwords rws scheduledtime = unwords tws prop_past_sane :: Bool prop_past_sane = and [ all (checksout oneMonthPast) (mplus1 ++ yplus1) , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1)) , all (checksout oneYearPast) yplus1 , all (not . (checksout oneYearPast)) (map swap yplus1) ] where mplus1 = -- new date old date, 1+ months before it [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15) , (fromGregorian 2014 01 15, fromGregorian 2013 02 15) , (fromGregorian 2014 02 15, fromGregorian 2013 01 15) , (fromGregorian 2014 03 01, fromGregorian 2013 01 15) , (fromGregorian 2014 03 01, fromGregorian 2013 12 15) , (fromGregorian 2015 01 01, fromGregorian 2010 01 01) ] yplus1 = -- new date old date, 1+ years before it [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16) , (fromGregorian 2014 01 15, fromGregorian 2013 01 14) , (fromGregorian 2022 12 31, fromGregorian 2000 01 01) ] checksout cmp (new, old) = new `cmp` old swap (a,b) = (b,a)