{- 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 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 $ reverse $ drop 1 $ reverse 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)