diff options
author | 2013-10-15 13:05:41 -0400 | |
---|---|---|
committer | 2013-10-15 13:27:21 -0400 | |
commit | e2d0b744e1588964e310482ac84aff3f1bea6b5e (patch) | |
tree | a87c22e580d404a74ec7538306042c2c01728a99 | |
parent | 23d762b3da197d2e438c565a40b1660859a84bbb (diff) |
add support for weekly, monthly, and yearly schedules that run on no specific day
-rw-r--r-- | Utility/Scheduled.hs | 195 | ||||
-rw-r--r-- | doc/design/assistant/disaster_recovery.mdwn | 6 |
2 files changed, 133 insertions, 68 deletions
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index e759ecef4..ce655b356 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -38,9 +38,9 @@ data Schedule = Schedule Recurrance ScheduledTime data Recurrance = Daily - | Weekly WeekDay - | Monthly MonthDay - | Yearly YearDay + | Weekly (Maybe WeekDay) + | Monthly (Maybe MonthDay) + | Yearly (Maybe YearDay) -- Days, Weeks, or Months of the year evenly divisible by a number. -- (Divisible Year is years evenly divisible by a number.) | Divisible Int Recurrance @@ -65,6 +65,10 @@ data NextTime | 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 @@ -76,77 +80,127 @@ nextTime schedule lasttime = do calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime | scheduledtime == AnyTime = do - start <- findfromtoday True - return $ NextTimeWindow - start - (LocalTime (localDay start) (TimeOfDay 23 59 0)) - | otherwise = NextTimeExactly <$> findfromtoday False + next <- findfromtoday True + return $ case next of + NextTimeWindow _ _ -> next + NextTimeExactly t -> window (localDay t) (localDay t) + | otherwise = NextTimeExactly . startTime <$> findfromtoday False where - findfromtoday anytime = - LocalTime <$> nextday <*> pure nexttime + findfromtoday anytime = findfrom recurrance afterday today where - nextday = findnextday recurrance afterday today today = localDay currenttime afterday = sameaslastday || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime - sameaslastday = (localDay <$> lasttime) == Just today + sameaslastday = lastday == Just today + lastday = localDay <$> lasttime nexttime = case scheduledtime of AnyTime -> TimeOfDay 0 0 0 SpecificTime h m -> TimeOfDay h m 0 - findnextday r afterday day = case r of + exactly d = NextTimeExactly $ LocalTime d nexttime + window startd endd = NextTimeWindow + (LocalTime startd nexttime) + (LocalTime endd (TimeOfDay 23 59 0)) + findfrom r afterday day = case r of Daily - | afterday -> Just $ addDays 1 day - | otherwise -> Just day - Weekly w + | afterday -> Just $ exactly $ addDays 1 day + | otherwise -> Just $ exactly day + Weekly Nothing + | afterday -> skip 1 + | otherwise -> case (wday <$> lastday, wday day) of + (Nothing, _) -> Just $ window day (addDays 6 day) + (Just old, curr) + | old == curr -> Just $ window day (addDays 6 day) + | otherwise -> skip 1 + Monthly Nothing + | afterday -> skip 1 + | maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday -> + -- Window only covers current month, + -- in case there is a Divisible requirement. + Just $ window day (endOfMonth day) + | otherwise -> skip 1 + Yearly Nothing + | afterday -> skip 1 + | maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday -> + Just $ window day (endOfYear day) + | otherwise -> skip 1 + Weekly (Just w) | w < 0 || w > maxwday -> Nothing | w == wday day -> if afterday - then Just $ addDays 7 day - else Just day - | otherwise -> Just $ + then Just $ exactly $ addDays 7 day + else Just $ exactly day + | otherwise -> Just $ exactly $ addDays (fromIntegral $ (w - wday day) `mod` 7) day - Monthly m + Monthly (Just 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 + then skip 1 + else Just $ exactly day + | otherwise -> skip 1 + Yearly (Just 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) + then skip 365 + else Just $ exactly day + | 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' year Nothing - Divisible _ r'@(Divisible _ _) -> findnextday r' afterday day + Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing + Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day where + skip n = findfrom r False (addDays n day) handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = - findnextdaywhere r' (divisible n . getval) afterday day + findfromwhere r' (divisible n . getval) afterday day | otherwise = Nothing - findnextdaywhere r p afterday day - | maybe True p d = d - | otherwise = maybe d (findnextdaywhere r p True) d + findfromwhere r p afterday day + | maybe True (p . getday) next = next + | otherwise = maybe Nothing (findfromwhere r p True . getday) next where - d = findnextday r afterday day + next = findfrom r afterday day + getday = localDay . startTime 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 +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 - maxyday = 366 -- with leap days - maxwnum = 53 -- some years have more than 52 - maxmday = 31 - maxmnum = 12 - maxwday = 7 +{- Calendar max and mins. -} +maxyday :: Int +maxyday = 366 -- with leap days +minyday :: Int +minyday = 365 +maxwnum :: Int +maxwnum = 53 -- some years have more than 52 +maxmday :: Int +maxmday = 31 +minmday :: Int +minmday = 28 +maxmnum :: Int +maxmnum = 12 +maxwday :: Int +maxwday = 7 fromRecurrance :: Recurrance -> String fromRecurrance (Divisible n r) = @@ -160,28 +214,40 @@ 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 :: Int -> String -> String -onday n s = "on day " ++ show n ++ " of " ++ s +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:[]) -> parse something sd + ("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 - <*> parse something sd + <*> withday sd something + ("every":something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> noday something _ -> Nothing where - parse "week" sd = withday Weekly sd - parse "month" sd = withday Monthly sd - parse "year" sd = withday Yearly sd - parse v sd - | "s" `isSuffixOf` v = parse (reverse $ drop 1 $ reverse v) sd + 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 c sd = c <$> readish sd + 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 @@ -255,18 +321,23 @@ instance Arbitrary ScheduledTime where instance Arbitrary Recurrance where arbitrary = oneof [ pure Daily - , Weekly <$> nonNegative arbitrary - , Monthly <$> nonNegative arbitrary - , Yearly <$> nonNegative arbitrary + , Weekly <$> arbday + , Monthly <$> arbday + , Yearly <$> arbday , Divisible <$> positive arbitrary <*> oneof -- no nested Divisibles [ pure Daily - , Weekly <$> nonNegative arbitrary - , Monthly <$> nonNegative arbitrary - , Yearly <$> nonNegative arbitrary + , 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 diff --git a/doc/design/assistant/disaster_recovery.mdwn b/doc/design/assistant/disaster_recovery.mdwn index 1379ccbc2..7f6991b17 100644 --- a/doc/design/assistant/disaster_recovery.mdwn +++ b/doc/design/assistant/disaster_recovery.mdwn @@ -42,12 +42,6 @@ prompt the user to eg, connect a drive containing it. Or perhaps this is a special case of a general problem, and the webapp should prompt the user when any desired file is available on a remote that's not mounted? -TODO: Enhance the Recurrance type to be able to do eg, events that run -once per month on any day, or once per year, or once per week. This -would be especially useful for removable drives, which might not be -plugged in on the 1st of the month. This should be the default in the -webapp (it's already worded to suggest this.) - ## git-annex-shell remote fsck TODO: git-annex-shell fsck support, which would allow cheap fast fscks |