From 7115d1ec162b4059b3e8e8f84bd8d5898c1db025 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 May 2014 19:41:05 -0400 Subject: moved source code to src This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work. --- src/Utility/Scheduled.hs | 396 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 396 insertions(+) create mode 100644 src/Utility/Scheduled.hs (limited to 'src/Utility/Scheduled.hs') diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs new file mode 100644 index 00000000..305410c5 --- /dev/null +++ b/src/Utility/Scheduled.hs @@ -0,0 +1,396 @@ +{- 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_schedule_roundtrips, + prop_past_sane, +) where + +import Utility.Data +import Utility.QuickCheck +import Utility.PartialPrelude +import Utility.Misc + +import Control.Applicative +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.Tuple.Utils +import Data.Char + +{- 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 = take (n - length s) (repeat '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 + +instance Arbitrary Schedule where + arbitrary = Schedule <$> arbitrary <*> arbitrary + +instance Arbitrary ScheduledTime where + arbitrary = oneof + [ pure AnyTime + , SpecificTime + <$> choose (0, 23) + <*> choose (1, 59) + ] + +instance Arbitrary Recurrance where + arbitrary = oneof + [ pure Daily + , Weekly <$> arbday + , Monthly <$> arbday + , Yearly <$> arbday + , Divisible + <$> positive arbitrary + <*> oneof -- no nested Divisibles + [ pure Daily + , 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 + +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) -- cgit v1.2.3