path: root/Utility/Scheduled.hs

{- scheduled activities
 - 
 - Copyright 2013-2014 Joey Hess <id@joeyh.name>
 -
 - 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)