add support for weekly, monthly, and yearly schedules that run on no specific day

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