diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Daemon.hs | 5 | ||||
| -rw-r--r-- | Utility/HumanTime.hs | 86 | ||||
| -rw-r--r-- | Utility/QuickCheck.hs | 3 | ||||
| -rw-r--r-- | Utility/Scheduled.hs | 270 |
4 files changed, 292 insertions, 72 deletions
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 2f942769a..12beb235a 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -16,6 +16,7 @@ import Utility.LogFile #ifndef mingw32_HOST_OS import System.Posix +import Control.Concurrent.Async #else import System.PosixCompat #endif @@ -46,7 +47,9 @@ daemonize logfd pidfile changedirectory a = do nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags redir nullfd stdInput redirLog logfd - a + {- forkProcess masks async exceptions; unmask them inside + - the action. -} + wait =<< asyncWithUnmask (\unmask -> unmask a) out out = exitImmediately ExitSuccess #else diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index 038d1228e..c55c862ca 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -1,26 +1,84 @@ {- Time for humans. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -module Utility.HumanTime where +module Utility.HumanTime ( + Duration(..), + durationToPOSIXTime, + parseDuration, + fromDuration, + prop_duration_roundtrips +) where import Utility.PartialPrelude +import Utility.Applicative +import Utility.QuickCheck import Data.Time.Clock.POSIX (POSIXTime) +import Data.Char +import Control.Applicative +import qualified Data.Map as M -{- Parses a human-input time duration, of the form "5h" or "1m". -} -parseDuration :: String -> Maybe POSIXTime -parseDuration s = do - num <- readish s :: Maybe Integer - units <- findUnits =<< lastMaybe s - return $ fromIntegral num * units +newtype Duration = Duration { durationSeconds :: Integer } + deriving (Eq, Ord, Read, Show) + +durationToPOSIXTime :: Duration -> POSIXTime +durationToPOSIXTime = fromIntegral . durationSeconds + +{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} +parseDuration :: String -> Maybe Duration +parseDuration = Duration <$$> go 0 + where + go n [] = return n + go n s = do + num <- readish s :: Maybe Integer + let (c:rest) = dropWhile isDigit s + u <- M.lookup c unitmap + go (n + num * u) rest + +fromDuration :: Duration -> String +fromDuration Duration { durationSeconds = d } + | d == 0 = "0s" + | otherwise = concat $ map showunit $ go [] units d where - findUnits 's' = Just 1 - findUnits 'm' = Just 60 - findUnits 'h' = Just $ 60 * 60 - findUnits 'd' = Just $ 60 * 60 * 24 - findUnits 'y' = Just $ 60 * 60 * 24 * 365 - findUnits _ = Nothing + showunit (u, n) + | n > 0 = show n ++ [u] + | otherwise = "" + go c [] _ = reverse c + go c ((u, n):us) v = + let (q,r) = v `quotRem` n + in go ((u, q):c) us r + +units :: [(Char, Integer)] +units = + [ ('y', ysecs) + , ('d', dsecs) + , ('h', hsecs) + , ('m', msecs) + , ('s', 1) + ] + +unitmap :: M.Map Char Integer +unitmap = M.fromList units + +ysecs :: Integer +ysecs = dsecs * 365 + +dsecs :: Integer +dsecs = hsecs * 24 + +hsecs :: Integer +hsecs = msecs * 60 + +msecs :: Integer +msecs = 60 + +-- Durations cannot be negative. +instance Arbitrary Duration where + arbitrary = Duration <$> nonNegative arbitrary + +prop_duration_roundtrips :: Duration -> Bool +prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 078b10c8b..82af09f3d 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -43,3 +43,6 @@ instance Arbitrary FileOffset where nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0) + +positive :: (Num a, Ord a) => Gen a -> Gen a +positive g = g `suchThat` (> 0) diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index 90d346280..5b667d285 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -8,40 +8,148 @@ module Utility.Scheduled ( Schedule(..), Recurrance(..), - TimeOfDay(..), + ScheduledTime(..), + NextTime(..), + nextTime, fromSchedule, - toSchedule + fromScheduledTime, + toScheduledTime, + fromRecurrance, + toRecurrance, + toSchedule, + parseSchedule, + prop_schedule_roundtrips ) where import Common +import Utility.QuickCheck + +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 TimeOfDay Duration - deriving (Show) +data Schedule = Schedule Recurrance ScheduledTime + deriving (Eq, Read, Show, Ord) data Recurrance = Daily | Weekly WeekDay | Monthly MonthDay | Yearly YearDay - -- Divisible 3 Daily is every day of the year evenly divisible by 3 - | Divisable Int Recurrance - deriving (Show) + -- Days, Weeks, or Months of the year evenly divisible by a number. + -- (Divisible Year is years evenly divisible by a number.) + | Divisible Int Recurrance + deriving (Eq, Read, Show, Ord) type WeekDay = Int type MonthDay = Int type YearDay = Int -data TimeOfDay +data ScheduledTime = AnyTime - | Hour Int - deriving (Show) + | 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) + +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 recurrance scheduledtime) lasttime currenttime + | scheduledtime == AnyTime = do + start <- findfromtoday + return $ NextTimeWindow + start + (LocalTime (localDay start) (TimeOfDay 23 59 0)) + | otherwise = NextTimeExactly <$> findfromtoday + where + findfromtoday = + LocalTime <$> nextday <*> pure nexttime + where + nextday = findnextday recurrance afterday today + today = localDay currenttime + afterday = sameaslastday || toolatetoday + toolatetoday = localTimeOfDay currenttime >= nexttime + sameaslastday = (localDay <$> lasttime) == Just today + nexttime = case scheduledtime of + AnyTime -> TimeOfDay 0 0 0 + SpecificTime h m -> TimeOfDay h m 0 + findnextday r afterday day = case r of + Daily + | afterday -> Just $ addDays 1 day + | otherwise -> Just day + Weekly w + | w < 0 || w > maxwday -> Nothing + | w == wday day -> if afterday + then Just $ addDays 7 day + else Just day + | otherwise -> Just $ + addDays (fromIntegral $ (w - wday day) `mod` 7) day + Monthly 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 + | 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) + 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 + where + handlediv n r' getval mmax + | n > 0 && maybe True (n <=) mmax = + findnextdaywhere 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 + where + d = findnextday r afterday day + divisible n v = v `rem` n == 0 -data Duration = MinutesDuration Int - deriving (Show) + -- 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 + + maxyday = 366 -- with leap days + maxwnum = 53 -- some years have more than 52 + maxmday = 31 + maxmnum = 12 + maxwday = 7 fromRecurrance :: Recurrance -> String -fromRecurrance (Divisable n r) = +fromRecurrance (Divisible n r) = fromRecurrance' (++ "s divisible by " ++ show n) r fromRecurrance r = fromRecurrance' ("every " ++) r @@ -50,67 +158,115 @@ 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 (Divisable _n r) = fromRecurrance' a r -- not used +fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used onday :: Int -> String -> String -onday n s = s ++ " on day " ++ show n +onday n s = "on day " ++ show n ++ " of " ++ s toRecurrance :: String -> Maybe Recurrance toRecurrance s = case words s of - ("every":something:l) -> parse something l - (something:"divisible":"by":sn:l) -> do - r <- parse something l - n <- readish sn - if n > 0 - then Just $ Divisable n r - else Nothing + ("every":"day":[]) -> Just Daily + ("on":"day":sd:"of":"every":something:[]) -> parse something sd + ("days":"divisible":"by":sn:[]) -> + Divisible <$> getdivisor sn <*> pure Daily + ("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> parse something sd _ -> Nothing where - parse "day" [] = Just Daily - parse "week" l = withday Weekly l - parse "month" l = withday Monthly l - parse "year" l = withday Yearly l - parse v l - | "s" `isSuffixOf` v = parse (reverse $ drop 1 $ reverse v) l + 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 | otherwise = Nothing - withday a ("on":"day":n:[]) = a <$> readish n - withday _ _ = Nothing - -fromTimeOfDay :: TimeOfDay -> String -fromTimeOfDay AnyTime = "any time" -fromTimeOfDay (Hour n) = "hour " ++ show n - -toTimeOfDay :: String -> Maybe TimeOfDay -toTimeOfDay s = case words s of - ("any":"time":[]) -> Just AnyTime - ("hour":n:[]) -> Hour <$> readish n - _ -> Nothing + withday c sd = c <$> readish sd + getdivisor sn = do + n <- readish sn + if n > 0 + then Just n + else Nothing -fromDuration :: Duration -> String -fromDuration (MinutesDuration n) = show n ++ " minutes" +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") -toDuration :: String -> Maybe Duration -toDuration s = case words s of - (n:"minutes":[]) -> MinutesDuration <$> readish n - (n:"minute":[]) -> MinutesDuration <$> readish n +toScheduledTime :: String -> Maybe ScheduledTime +toScheduledTime "any time" = Just AnyTime +toScheduledTime v = case words v of + (s:ampm:[]) + | map toUpper ampm == "AM" -> + go s (\h -> if h == 12 then 0 else h) + | map toUpper ampm == "PM" -> + go s (+ 12) + | otherwise -> Nothing + (s:[]) -> go s id _ -> Nothing + where + 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 timeofday duration) = unwords +fromSchedule (Schedule recurrance scheduledtime) = unwords [ fromRecurrance recurrance , "at" - , fromTimeOfDay timeofday - , "for" - , fromDuration duration + , fromScheduledTime scheduledtime ] toSchedule :: String -> Maybe Schedule -toSchedule s = Schedule - <$> toRecurrance (unwords recurrance) - <*> toTimeOfDay (unwords timeofday) - <*> toDuration (unwords duration) +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 - ws = words s - (recurrance, ws') = separate (== "at") ws - (timeofday, duration) = separate (== "for") ws' + (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 + <$> nonNegative arbitrary + <*> nonNegative arbitrary + ] + +instance Arbitrary Recurrance where + arbitrary = oneof + [ pure Daily + , Weekly <$> nonNegative arbitrary + , Monthly <$> nonNegative arbitrary + , Yearly <$> nonNegative arbitrary + , Divisible + <$> positive arbitrary + <*> oneof -- no nested Divisibles + [ pure Daily + , Weekly <$> nonNegative arbitrary + , Monthly <$> nonNegative arbitrary + , Yearly <$> nonNegative arbitrary + ] + ] +prop_schedule_roundtrips :: Schedule -> Bool +prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s |