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. --- Utility/Scheduled.hs | 396 --------------------------------------------------- 1 file changed, 396 deletions(-) delete mode 100644 Utility/Scheduled.hs (limited to 'Utility/Scheduled.hs') diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs deleted file mode 100644 index 305410c5..00000000 --- a/Utility/Scheduled.hs +++ /dev/null @@ -1,396 +0,0 @@ -{- 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