diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2012, Michael Xavier. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +cron +==== +[![Build Status](https://secure.travis-ci.org/MichaelXavier/cron.png)](http://travis-ci.org/MichaelXavier/cron) + +Cron data structure and Attoparsec parser for Haskell. The idea is to embed it +in larger systems which want to roll their own scheduled tasks in a format that +people are used to. + +`System.Cron` is where all the interesting datatypes live. You will also find +`scheduleMatches`, which you can use to compare a time against a `CronSchedule` +to see if an action needs to be performed. System.Cron.Parser is where you will +find the parsers `cronSchedule`, `crontabEntry` and `cronTab`. To parse +individual schedules up to full crontab files. + + +To do anything, you'll need to install cabal-dev with cabal. + +To build, run: + + make + +To run tests, run: + + make test + +If you have inotify-tools, run this to run tests continuously. + + make autotest + +To generate docs: + + make docs + +#### Scheduler +Cron offers a scheduling monad which can be found in `System.Cron.Schedule`. This monad transform allows you to declare a set of jobs (of the type `IO ()`) that will be executed at intervals defined by cron strings. + +```haskell +main :: IO () +main = do + ... + tids <- execSchedule $ do + addJob job1 "* * * * *" + addJob job2 "0 * * * *" + print tids + ... + +job1 :: IO () +job1 = putStrLn "Job 1" + +job2 :: IO () +job2 = putStrLn "Job 2" +``` + +## Contributors + +* [Simon Hengel](https://github.com/sol) +* [Alberto Valverde](https://github.com/albertov) +* [Andrew Rademacher](https://github.com/AndrewRademacher) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,12 @@ +# 0.2.5 +* GHC 7.10 support +# 0.2.4 +* Bugfixes for new task runner feature +# 0.2.3 +* Add new in-process task runner feature. Credit to @AndrewRademacher +# 0.2.2 +* Fix edge case when day of month and day of week are both specified. Credit to @joelwilliamson +# 0.2.1 +* Fix day of week bug. Credit to @meteogrid +# 0.1.2 +* Relax dependency on text to allow 1.0 diff --git a/cron-compat.cabal b/cron-compat.cabal new file mode 100644 --- /dev/null +++ b/cron-compat.cabal @@ -0,0 +1,76 @@ +Name: cron-compat +Version: 0.2.6 +Description: + Cron data structure and Attoparsec parser. The idea is to embed it in larger + systems which want to roll their own scheduled tasks in a format that people + are used to. + + 'System.Cron' is where all the interesting datatypes live. You will also find + 'scheduleMatches', which you can use to compare a time against a + 'CronSchedule' to see if an action needs to be performed. System.Cron.Parser + is where you will find the parsers `cronSchedule`, `crontabEntry` and + `cronTab`. To parse individual schedules up to full crontab files. + +Synopsis: Cron datatypes and Attoparsec parser +Category: Text, Parsing, System +License: MIT +License-file: LICENSE +Author: Michael Xavier +Copyright: Copyright: (c) 2012-2014 Michael Xavier +Maintainer: Michael Xavier +Build-Type: Simple +Stability: experimental +Tested-With: GHC == 7.4.1 + , GHC == 7.6.3 + , GHC == 7.8.3 + , GHC == 7.10.1 +Cabal-Version: >= 1.8 +Extra-Source-Files: + README.md + LICENSE + changelog + test/Spec.hs + test/System/Cron/ParserSpec.hs + test/System/CronSpec.hs +Homepage: http://github.com/michaelxavier/cron +Bug-Reports: http://github.com/michaelxavier/cron/issues + +library + Exposed-modules: System.Cron, + System.Cron.Parser, + System.Cron.Schedule + Ghc-Options: -Wall + Hs-source-dirs: src + build-depends: base >= 4 && < 5, + attoparsec >= 0.10, + text >= 0.11 && < 2, + time >= 1.4, + old-locale >= 1.0, + mtl >= 2.1 && <= 2.2, + mtl-compat >= 0.2.1 && <= 0.2.2, + transformers-compat >= 0.3.0.0 + + +test-suite spec + Type: exitcode-stdio-1.0 + Main-Is: Spec.hs + Hs-Source-Dirs: test + Other-Modules: SpecHelper + System.Cron.ParserSpec + System.Cron.ScheduleSpec + System.CronSpec + Build-Depends: base >= 4 && < 5, + cron, + hspec >= 1.3, + QuickCheck, + derive, + hspec-expectations, + attoparsec >= 0.10, + text >= 0.11 && < 2, + time >= 1.4, + transformers >= 0.4 + Ghc-Options: -threaded -rtsopts + +source-repository head + Type: git + Location: https://github.com/michaelxavier/cron diff --git a/src/System/Cron.hs b/src/System/Cron.hs new file mode 100644 --- /dev/null +++ b/src/System/Cron.hs @@ -0,0 +1,246 @@ +-------------------------------------------------------------------- +-- | +-- Module : System.Cron +-- Description : Datatype for Cron Schedule and helpful functions +-- Copyright : (c) Michael Xavier 2012 +-- License : MIT +-- +-- Maintainer: Michael Xavier +-- Portability: portable +-- +-- Toplevel module for Cron specifying a cron schedule and several convenience +-- functions for dealing with cron schedules +-- +-- > import Control.Concurrent +-- > import Control.Monad +-- > import Data.Time.Clock +-- > import System.Cron +-- > +-- > main :: IO () +-- > main = forever $ do +-- > now <- getCurrentTime +-- > when (scheduleMatches schedule now) doWork +-- > putStrLn "sleeping" +-- > threadDelay 100000 +-- > where doWork = putStrLn "Time to work" +-- > schedule = hourly +-- +-------------------------------------------------------------------- +module System.Cron (CronSchedule(..), + Crontab(..), + CrontabEntry(..), + MinuteSpec(..), + HourSpec(..), + MonthSpec(..), + DayOfMonthSpec(..), + DayOfWeekSpec(..), + CronField(..), + yearly, + monthly, + daily, + weekly, + hourly, + everyMinute, + scheduleMatches) where + +import Data.List (intercalate) + +import Data.Text (Text, unpack) +import Data.Time.Calendar (toGregorian) +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime(..)) +import Data.Time.LocalTime (TimeOfDay(..), timeToTimeOfDay) + +-- | Specification for a cron expression +data CronSchedule = CronSchedule { minute :: MinuteSpec, -- ^ Which minutes to run. First field in a cron specification. + hour :: HourSpec, -- ^ Which hours to run. Second field in a cron specification. + dayOfMonth :: DayOfMonthSpec, -- ^ Which days of the month to run. Third field in a cron specification. + month :: MonthSpec, -- ^ Which months to run. Fourth field in a cron specification. + dayOfWeek :: DayOfWeekSpec -- ^ Which days of the week to run. Fifth field in a cron specification. + } + deriving (Eq) + +instance Show CronSchedule where + show cs = "CronSchedule " ++ showRaw cs + +showRaw :: CronSchedule + -> String +showRaw cs = unwords [show $ minute cs, + show $ hour cs, + show $ dayOfMonth cs, + show $ month cs, + show $ dayOfWeek cs] + +-- | Crontab file, omitting comments. +newtype Crontab = Crontab [CrontabEntry] + deriving (Eq) + +instance Show Crontab where + show (Crontab entries) = intercalate "\n" . map show $ entries + +-- | Essentially a line in a crontab file. It is either a schedule with a +-- command after it or setting an environment variable (e.g. FOO=BAR) +data CrontabEntry = CommandEntry { schedule :: CronSchedule, + command :: Text} | + EnvVariable { varName :: Text, + varValue :: Text } + deriving (Eq) + +instance Show CrontabEntry where + show CommandEntry { schedule = s, command = c} = showRaw s ++ " " ++ unpack c + show EnvVariable { varName = n, varValue = v} = unpack n ++ "=" ++ unpack v + +-- | Minutes field of a cron expression +data MinuteSpec = Minutes CronField + deriving (Eq) + +instance Show MinuteSpec where + show (Minutes cf) = show cf + +-- | Hours field of a cron expression +data HourSpec = Hours CronField + deriving (Eq) + +instance Show HourSpec where + show (Hours cf) = show cf + +-- | Day of month field of a cron expression +data DayOfMonthSpec = DaysOfMonth CronField + deriving (Eq) + +instance Show DayOfMonthSpec where + show (DaysOfMonth cf) = show cf + +-- | Month field of a cron expression +data MonthSpec = Months CronField + deriving (Eq) + +instance Show MonthSpec where + show (Months cf) = show cf + +-- | Day of week field of a cron expression +data DayOfWeekSpec = DaysOfWeek CronField + deriving (Eq) + +instance Show DayOfWeekSpec where + show (DaysOfWeek cf) = show cf + +-- | Individual field of a cron expression. +data CronField = Star | -- ^ Matches anything + SpecificField Int | -- ^ Matches a specific value (e.g. 1) + RangeField Int Int | -- ^ Matches a range of values (e.g. 1-3) + ListField [CronField] | -- ^ Matches a list of expressions. Recursive lists are invalid and the parser will never produce them. + StepField CronField Int -- ^ Matches a stepped expression, e.g. (*/2). Recursive steps or stepped lists are invalid and the parser will never produce them. + deriving (Eq) + +instance Show CronField where + show Star = "*" + show (SpecificField i) = show i + show (RangeField x y) = show x ++ "-" ++ show y + show (ListField xs) = intercalate "," $ map show xs + show (StepField f step) = show f ++ "/" ++ show step + + +-- | Shorthand for every January 1st at midnight. Parsed with \@yearly, 0 0 1 1 * +yearly :: CronSchedule +yearly = monthly { month = Months $ SpecificField 1 } + +-- | Shorthand for every 1st of the month at midnight. Parsed with \@monthly, 0 0 1 * * +monthly :: CronSchedule +monthly = daily { dayOfMonth = DaysOfMonth $ SpecificField 1 } + +-- | Shorthand for every sunday at midnight. Parsed with \@weekly, 0 0 * * 0 +weekly :: CronSchedule +weekly = daily { dayOfWeek = DaysOfWeek $ SpecificField 0 } + +-- | Shorthand for every day at midnight. Parsed with \@daily, 0 0 * * * +daily :: CronSchedule +daily = hourly { hour = Hours $ SpecificField 0 } + +-- | Shorthand for every hour on the hour. Parsed with \@hourly, 0 * * * * +hourly :: CronSchedule +hourly = everyMinute { minute = Minutes $ SpecificField 0 } + +-- | Shorthand for an expression that always matches. Parsed with * * * * * +everyMinute :: CronSchedule +everyMinute = CronSchedule { minute = Minutes Star, + hour = Hours Star, + dayOfMonth = DaysOfMonth Star, + month = Months Star, + dayOfWeek = DaysOfWeek Star} + +-- | Determines if the given time is matched by the given schedule. A +-- periodical task would use this to determine if an action needs to be +-- performed at the current time or not. +scheduleMatches :: CronSchedule + -> UTCTime + -> Bool +scheduleMatches CronSchedule { minute = Minutes mins, + hour = Hours hrs, + dayOfMonth = DaysOfMonth doms, + month = Months months, + dayOfWeek = DaysOfWeek dows } + UTCTime { utctDay = uDay, + utctDayTime = uTime } = if restricted doms && restricted dows + then mnv && hrv && mthv && (domv || dowv) + else mnv && hrv && mthv && domv && dowv + where (_, mth, dom) = toGregorian uDay + (_, _, dow) = toWeekDate uDay + TimeOfDay { todHour = hr, + todMin = mn} = timeToTimeOfDay uTime + [mnv,hrv,domv,mthv,dowv] = map validate [(mn, CMinute, mins), + (hr, CHour, hrs), + (dom, CDayOfMonth, doms), + (mth, CMonth, months), + (dow, CDayOfWeek, dows)] + validate (x, y, z) = matchField x y z + restricted Star = False + restricted (SpecificField _) = True + restricted (RangeField _ _) = True + restricted (ListField _) = True + restricted (StepField f _) = restricted f + +matchField :: Int + -> CronUnit + -> CronField + -> Bool +matchField _ _ Star = True +matchField x CDayOfWeek (SpecificField y) + | x == y || x == 0 && y == 7 || x == 7 && y == 0 = True + | otherwise = False +matchField x _ (SpecificField y) = x == y +matchField x _ (RangeField y y') = x >= y && x <= y' +matchField x unit (ListField fs) = any (matchField x unit) fs +matchField x unit (StepField f step) = elem x $ expandDivided f step unit + +expandDivided :: CronField + -> Int + -> CronUnit + -> [Int] +expandDivided Star step unit = fillTo 0 max' step + where max' = maxValue unit +expandDivided (RangeField start finish) step unit = fillTo start finish' step + where finish' = minimum [finish, maxValue unit] +expandDivided _ _ _ = [] -- invalid + +fillTo :: Int + -> Int + -> Int + -> [Int] +fillTo start finish step + | step <= 0 = [] + | finish < start = [] + | otherwise = [ x | x <- [start..finish], x `mod` step == 0] + +data CronUnit = CMinute | + CHour | + CDayOfMonth | + CMonth | + CDayOfWeek deriving (Show, Eq) + +maxValue :: CronUnit -> Int +maxValue CMinute = 59 +maxValue CHour = 23 +maxValue CDayOfMonth = 31 +maxValue CMonth = 12 +maxValue CDayOfWeek = 6 diff --git a/src/System/Cron/Parser.hs b/src/System/Cron/Parser.hs new file mode 100644 --- /dev/null +++ b/src/System/Cron/Parser.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +-------------------------------------------------------------------- +-- | +-- Module : System.Cron.Parser +-- Description : Attoparsec parser for cron formatted intervals +-- Copyright : (c) Michael Xavier 2012 +-- License : MIT +-- +-- Maintainer: Michael Xavier +-- Portability: portable +-- +-- Attoparsec parser combinator for cron schedules. See cron documentation for +-- how those are formatted. +-- +-- > import Data.Attoparsec.Text (parseOnly) +-- > import System.Cron.Parser +-- > +-- > main :: IO () +-- > main = do +-- > print $ parseOnly cronSchedule "*/2 * 3 * 4,5,6" +-- +-------------------------------------------------------------------- +module System.Cron.Parser (cronSchedule, + cronScheduleLoose, + crontab, + crontabEntry) where + +import System.Cron + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure, (*>), (<$>), (<*), (<*>), (<|>)) +#else +import Control.Applicative ((<$>), (<|>)) +#endif +import Data.Char (isSpace) +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as A +import Data.Text (Text) + +-- | Attoparsec Parser for a cron schedule. Complies fully with the standard +-- cron format. Also includes the following shorthand formats which cron also +-- supports: \@yearly, \@monthly, \@weekly, \@daily, \@hourly. Note that this +-- parser will fail if there is extraneous input. This is to prevent things +-- like extra fields. If you want a more lax parser, use 'cronScheduleLoose', +-- which is fine with extra input. +cronSchedule :: Parser CronSchedule +cronSchedule = cronScheduleLoose <* A.endOfInput + +-- | Same as 'cronSchedule' but does not fail on extraneous input. +cronScheduleLoose :: Parser CronSchedule +cronScheduleLoose = yearlyP <|> + monthlyP <|> + weeklyP <|> + dailyP <|> + hourlyP <|> + classicP + +-- | Parses a full crontab file, omitting comments and including environment +-- variable sets (e.g FOO=BAR). +crontab :: Parser Crontab +crontab = Crontab <$> A.sepBy lineP (A.char '\n') + where lineP = A.skipMany commentP *> crontabEntry + commentP = A.skipSpace *> A.char '#' *> skipToEOL + +-- | Parses an individual crontab line, which is either a scheduled command or +-- an environmental variable set. +crontabEntry :: Parser CrontabEntry +crontabEntry = A.skipSpace *> parser + where parser = envVariableP <|> + commandEntryP + envVariableP = do var <- A.takeWhile1 (A.notInClass " =") + A.skipSpace + _ <- A.char '=' + A.skipSpace + val <- A.takeWhile1 $ not . isSpace + A.skipWhile (\c -> c == ' ' || c == '\t') + return $ EnvVariable var val + commandEntryP = CommandEntry <$> cronScheduleLoose + <*> (A.skipSpace *> takeToEOL) + +---- Internals +takeToEOL :: Parser Text +takeToEOL = A.takeTill (== '\n') -- <* A.skip (== '\n') + +skipToEOL :: Parser () +skipToEOL = A.skipWhile (/= '\n') + +classicP :: Parser CronSchedule +classicP = CronSchedule <$> (minutesP <* space) + <*> (hoursP <* space) + <*> (dayOfMonthP <* space) + <*> (monthP <* space) + <*> dayOfWeekP + where space = A.char ' ' + +cronFieldP :: Parser CronField +cronFieldP = steppedP <|> + rangeP <|> + listP <|> + starP <|> + specificP + where starP = A.char '*' *> pure Star + rangeP = do start <- parseInt + _ <- A.char '-' + end <- parseInt + if start <= end + then return $ RangeField start end + else rangeInvalid + rangeInvalid = fail "start of range must be less than or equal to end" + -- Must avoid infinitely recursive parsers + listP = reduceList <$> A.sepBy1 listableP (A.char ',') + listableP = starP <|> + rangeP <|> + steppedP <|> + specificP + stepListP = ListField <$> A.sepBy1 stepListableP (A.char ',') + stepListableP = starP <|> + rangeP + steppedP = StepField <$> steppableP <*> (A.char '/' *> parseInt) + steppableP = starP <|> + rangeP <|> + stepListP <|> + specificP + specificP = SpecificField <$> parseInt + +yearlyP :: Parser CronSchedule +yearlyP = A.string "@yearly" *> pure yearly + +monthlyP :: Parser CronSchedule +monthlyP = A.string "@monthly" *> pure monthly + +weeklyP :: Parser CronSchedule +weeklyP = A.string "@weekly" *> pure weekly + +dailyP :: Parser CronSchedule +dailyP = A.string "@daily" *> pure daily + +hourlyP :: Parser CronSchedule +hourlyP = A.string "@hourly" *> pure hourly + + +--TODO: must handle a combination of many of these. EITHER just *, OR a list of +minutesP :: Parser MinuteSpec +minutesP = Minutes <$> cronFieldP + +hoursP :: Parser HourSpec +hoursP = Hours <$> cronFieldP + +dayOfMonthP :: Parser DayOfMonthSpec +dayOfMonthP = DaysOfMonth <$> cronFieldP + +monthP :: Parser MonthSpec +monthP = Months <$> cronFieldP + +dayOfWeekP :: Parser DayOfWeekSpec +dayOfWeekP = DaysOfWeek <$> cronFieldP + +parseInt :: Parser Int +parseInt = A.decimal + +reduceList :: [CronField] -> CronField +reduceList [] = ListField [] -- this should not happen +reduceList [x] = x +reduceList xs = ListField xs diff --git a/src/System/Cron/Schedule.hs b/src/System/Cron/Schedule.hs new file mode 100644 --- /dev/null +++ b/src/System/Cron/Schedule.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------- +-- | +-- Module : System.Cron.Schedule +-- Description : Monad stack for scheduling jobs to be executed by cron rules. +-- Copyright : (c) Andrew Rademacher 2014 +-- License : MIT +-- +-- Maintainer: Andrew Rademacher +-- Portability: portable +-- +-- > main :: IO () +-- > main = do +-- > ... +-- > tids <- execSchedule $ do +-- > addJob job1 "* * * * *" +-- > addJob job2 "0 * * * *" +-- > print tids +-- > ... +-- > +-- > job1 :: IO () +-- > job1 = putStrLn "Job 1" +-- > +-- > job2 :: IO () +-- > job2 = putStrLn "Job 2" +-- +-------------------------------------------------------------------- + +module System.Cron.Schedule + ( Job (..) + , ScheduleError (..) + , Schedule + , ScheduleT (..) + + , MonadSchedule (..) + + , runSchedule + , runScheduleT + + , execSchedule + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Concurrent +import Control.Monad.Except +import Control.Monad.Trans.Except +import Control.Monad.Error.Class +import Control.Monad.Identity +import Control.Monad.State +import Data.Attoparsec.Text (parseOnly) +import Data.Text (pack) +import Data.Time +import System.Cron +import System.Cron.Parser +#if !MIN_VERSION_time(1,5,0) +import System.Locale +#endif + +readTime' :: TimeLocale -> String -> String -> UTCTime +#if MIN_VERSION_time(1,5,0) +readTime' = parseTimeOrError True +#else +readTime' = readTime +#endif + +{- Scheduleing monad -} + +data Job = Job CronSchedule (IO ()) +type Jobs = [Job] + +instance Show Job where + show (Job c _) = "(Job " ++ show c ++ ")" + +data ScheduleError = ParseError String + deriving (Show) + +type Schedule = ScheduleT Identity + +newtype ScheduleT m a = ScheduleT { unSchedule :: StateT Jobs (ExceptT ScheduleError m) a } + deriving ( Functor, Applicative, Monad + , MonadState Jobs + , MonadError ScheduleError + ) + +runSchedule :: Schedule a -> Either ScheduleError (a, [Job]) +runSchedule = runIdentity . runScheduleT + +runScheduleT :: ScheduleT m a -> m (Either ScheduleError (a, [Job])) +runScheduleT = runExceptT . flip runStateT [] . unSchedule + +class MonadSchedule m where + addJob :: IO () -> String -> m () + +instance (Monad m) => MonadSchedule (ScheduleT m) where + addJob a t = do s :: Jobs <- get + case parseOnly cronSchedule (pack t) of + Left e -> throwError $ ParseError e + Right t' -> put $ Job t' a : s + +{- Monitoring Engine -} + +execSchedule :: Schedule () -> IO [ThreadId] +execSchedule s = let res = runSchedule s + in case res of + Left e -> print e >> return [] + Right (_, jobs) -> mapM forkJob jobs + +forkJob :: Job -> IO ThreadId +forkJob (Job s a) = forkIO $ forever $ do + (timeAt, delay) <- findNextMinuteDelay + threadDelay delay + when (scheduleMatches s timeAt) a + +findNextMinuteDelay :: IO (UTCTime, Int) +findNextMinuteDelay = do + now <- getCurrentTime + let f = formatTime defaultTimeLocale fmtFront now + m = (read (formatTime defaultTimeLocale fmtMinutes now) :: Int) + 1 + r = f ++ ":" ++ if length (show m) == 1 then "0" ++ show m else show m + next = readTime' defaultTimeLocale fmtRead r :: UTCTime + diff = diffUTCTime next now + delay = round (realToFrac (diff * 1000000) :: Double) :: Int + return (next, delay) + where fmtFront = "%F %H" + fmtMinutes = "%M" + fmtRead = "%F %H:%M" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 --- /dev/null +++ b/test/SpecHelper.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} +module SpecHelper (module X) where + +import Control.Applicative as X +import Data.DeriveTH +import Data.Time.Clock as X +import Data.Time.Calendar as X +import Data.Time.LocalTime as X +import Test.Hspec as X +import Test.Hspec.QuickCheck as X +import Test.QuickCheck as X + +import System.Cron as X + +import Debug.Trace as X + +instance Arbitrary UTCTime where + arbitrary = do + d <- ModifiedJulianDay . fromInteger . getPositive <$> arbitrary + t <- fromInteger . getPositive <$> arbitrary + return $ UTCTime d t + +$(derive makeArbitrary ''CronField) +$(derive makeArbitrary ''MinuteSpec) +$(derive makeArbitrary ''HourSpec) +$(derive makeArbitrary ''DayOfWeekSpec) +$(derive makeArbitrary ''DayOfMonthSpec) +$(derive makeArbitrary ''MonthSpec) +$(derive makeArbitrary ''CronSchedule) diff --git a/test/System/Cron/ParserSpec.hs b/test/System/Cron/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Cron/ParserSpec.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +module System.Cron.ParserSpec (spec) where +-- TODO: this *should* just work with {-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +import Data.Attoparsec.Text (parseOnly, Parser) +import Data.Text (Text) +import Test.Hspec + +import System.Cron +import System.Cron.Parser +import Test.Hspec.Expectations.Contrib (isLeft) + +spec :: Spec +spec = sequence_ [describeCronSchedule, + describeCronScheduleLoose, + describeCrontab, + describeCrontabEntry] + +describeCronSchedule :: Spec +describeCronSchedule = describe "cronSchedule" $ do + it "parses all stars" $ + assertSuccessfulParse "* * * * *" + stars + + it "parses specific values" $ + assertSuccessfulParse "1 2 3 * *" + stars { minute = Minutes (SpecificField 1), + hour = Hours (SpecificField 2), + dayOfMonth = DaysOfMonth (SpecificField 3) } + + it "parses list values" $ + assertSuccessfulParse "* * 3,4 * *" + stars { dayOfMonth = DaysOfMonth (ListField [SpecificField 3, + SpecificField 4]) } + + it "parses range values" $ + assertSuccessfulParse "* * 3-4 * *" + stars { dayOfMonth = DaysOfMonth (RangeField 3 4) } + + it "parses step values" $ + assertSuccessfulParse "*/2 * 2-10/4 * *" + stars { minute = Minutes (StepField Star 2), + dayOfMonth = DaysOfMonth (StepField (RangeField 2 10) 4) } + + it "refuses to parse recursive steps" $ + assertFailedParse "*/2/3 * * * *" + + it "refuses to parse sparse lists" $ + assertFailedParse "1,,2 * * * *" + + it "refuses too few fields" $ + assertFailedParse "* * * *" + + it "refuses too many fields" $ + assertFailedParse "* * * * * *" + + it "refuses extraneous input" $ + assertFailedParse "* * * * * wat is this" + + it "parses @hourly" $ + assertSuccessfulParse "@hourly" hourly + + it "parses @daily" $ + assertSuccessfulParse "@daily" daily + + it "parses @monthly" $ + assertSuccessfulParse "@monthly" monthly + + it "parses @yearly" $ + assertSuccessfulParse "@yearly" yearly + + it "parses ranges at the last field" $ + assertSuccessfulParse "* * * * 3-4" + stars { dayOfWeek = DaysOfWeek (RangeField 3 4) } + it "parses lists at the last field" $ + assertSuccessfulParse "* * * * 3,4" + stars { dayOfWeek = DaysOfWeek (ListField [SpecificField 3, + SpecificField 4]) } + it "parses steps at the last field" $ + assertSuccessfulParse "* * * * */4" + stars { dayOfWeek = DaysOfWeek (StepField Star 4) } + it "parses a sunday as 7" $ + assertSuccessfulParse "* * * * 7" + stars { dayOfWeek = DaysOfWeek (SpecificField 7) } + it "parses a sunday as 0" $ + assertSuccessfulParse "* * * * 0" + stars { dayOfWeek = DaysOfWeek (SpecificField 0) } + where assertSuccessfulParse = assertParse cronSchedule + assertFailedParse = assertNoParse cronSchedule + +describeCronScheduleLoose :: Spec +describeCronScheduleLoose = describe "cronScheduleLoose" $ do + it "is okay with extaneous input" $ + assertSuccessfulParse "* * * * * *" + stars + where assertSuccessfulParse = assertParse cronScheduleLoose + +describeCrontab :: Spec +describeCrontab = describe "crontab" $ do + it "parses an empty input" $ + assertSuccessfulParse "" + (Crontab []) + + it "parses whitespace" $ + assertSuccessfulParse " " + (Crontab []) + + it "parses a single line" $ + assertSuccessfulParse " " + (Crontab []) + + it "ignores comments" $ + assertSuccessfulParse "# comment" + (Crontab []) + + it "ignores comments with leading whitespace" $ + assertSuccessfulParse " # comment" + (Crontab []) + + it "parses comments interspersed with actual commands" $ + assertSuccessfulParse "#comment here\nFOO=BAR\n #another\n* * * * * do stuff" + (Crontab [envSet, entry]) + + where assertSuccessfulParse = assertParse crontab + +describeCrontabEntry :: Spec +describeCrontabEntry = describe "crontabEntry" $ do + it "parses an environment variable assignment" $ + assertSuccessfulParse "FOO=BAR" + envSet + + it "parses an environment variable with whitespace at the front" $ + assertSuccessfulParse " FOO=BAR" + envSet + + it "parses an environment variable with whitespace in the middle" $ + assertSuccessfulParse " FOO = BAR" + envSet + + it "parses a command" $ + assertSuccessfulParse "* * * * * do stuff" + entry + + it "parses a command with any amount of whitespace inbetween" $ + assertSuccessfulParse "* * * * * do stuff" + entry + + it "parses a command with whitespace at the front" $ + assertSuccessfulParse " * * * * * do stuff" + entry + where assertSuccessfulParse = assertParse crontabEntry + +assertParse :: (Eq a, Show a) + => Parser a + -> Text + -> a + -> Expectation +assertParse parser txt expected = parsed `shouldBe` Right expected + where parsed = parseOnly parser txt + +--assertNoParse :: Parser a -> Text -> b +assertNoParse :: (Eq a, Show a) + => Parser a + -> Text + -> Expectation +assertNoParse parser txt = parseOnly parser txt `shouldSatisfy` isLeft + +envSet :: CrontabEntry +envSet = EnvVariable "FOO" "BAR" + +entry :: CrontabEntry +entry = CommandEntry stars "do stuff" + +stars :: CronSchedule +stars = CronSchedule (Minutes Star) + (Hours Star) + (DaysOfMonth Star) + (Months Star) + (DaysOfWeek Star) diff --git a/test/System/Cron/ScheduleSpec.hs b/test/System/Cron/ScheduleSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Cron/ScheduleSpec.hs @@ -0,0 +1,45 @@ +module System.Cron.ScheduleSpec + ( spec + ) where + +import Control.Concurrent +import Test.Hspec + +import System.Cron.Schedule + +spec :: Spec +spec = sequence_ [ describeMonadSchedule + , describeExecSchedule + ] + +empty :: IO () +empty = return () + +flipMVar :: MVar String -> IO () +flipMVar v = putMVar v "dost thou even hoist" + +describeMonadSchedule :: Spec +describeMonadSchedule = describe "MonadSchedule" $ do + let Right ((), s) = runSchedule (do addJob empty "* * * * *" + addJob empty "0 * * * *" + addJob empty "0 0 * * *") + it "should place the first job as the last job stated." $ + let (Job x _) = (s !! 0) + in show x `shouldBe` "CronSchedule 0 0 * * *" + it "should place the last job as the first job stated." $ + let (Job x _) = (s !! 2) + in show x `shouldBe` "CronSchedule * * * * *" + it "should read all three jobs." $ + length s `shouldBe` 3 + +describeExecSchedule :: Spec +describeExecSchedule = describe "execSchedule" $ do + it "should set an mvar each minute" $ + fireAndWait >>= (`shouldBe` "dost thou even hoist") + where fireAndWait = do + v <- newEmptyMVar + tids <- execSchedule $ do + addJob (flipMVar v) "* * * * *" + threadDelay (1000000 * 60) + mapM_ killThread tids + takeMVar v diff --git a/test/System/CronSpec.hs b/test/System/CronSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/CronSpec.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE OverloadedStrings #-} +module System.CronSpec (spec) where + +import SpecHelper + +spec :: Spec +spec = sequence_ [describeScheduleMatches, + describeCronScheduleShow, + describeCrontabEntryShow, + describeCrontabShow ] + +---- Specs +describeScheduleMatches :: Spec +describeScheduleMatches = describe "ScheduleMatches" $ do + it "matches a catch-all" $ + scheduleMatches stars (day 5 25 1 2) + + it "matches a specific field" $ + scheduleMatches stars { hour = Hours (SpecificField 1)} + (day 5 25 1 2) + + it "matches a range" $ + scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 3 5)} + (day 5 4 1 2) + + it "does not match invalid range" $ + not $ scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 5 3)} + (day 5 4 1 2) + + it "matches a list" $ + scheduleMatches stars { month = Months (ListField [SpecificField 1, + SpecificField 2, + SpecificField 3])} + (day 2 3 1 2) + + it "matches a step field" $ + scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 10 16) 2)} + (day 5 12 1 2) + + it "does not match something missing the step field" $ + not $ scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 10 16) 2)} + (day 5 13 1 2) + + it "matches starred stepped fields" $ + scheduleMatches stars { minute = Minutes (StepField Star 2)} + (day 5 13 1 4) + + it "does not match fields that miss starred stepped fields" $ + not $ scheduleMatches stars { minute = Minutes (StepField Star 2)} + (day 5 13 1 5) + + it "matches multiple fields at once" $ + scheduleMatches stars { minute = Minutes (StepField Star 2), + dayOfMonth = DaysOfMonth (SpecificField 3), + hour = Hours (RangeField 10 14) } + (day 5 3 13 2) + + it "matches a monday as 1" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1) } + (UTCTime (fromGregorian 2014 3 17) 0) + + it "matches a sunday as 0" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 0) } + (UTCTime (fromGregorian 2014 3 16) 0) + + it "matches a sunday as 7" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 7) } + (UTCTime (fromGregorian 2014 3 16) 0) + + it "matches weekly on a sunday at 0:00" $ + scheduleMatches weekly (UTCTime (fromGregorian 2014 4 6) 0) + + it "does not match weekly on a sunday at some time past midnight" $ + not $ scheduleMatches weekly (UTCTime (fromGregorian 2014 6 4) 600) + + it "does not match weekly on another day at midnight" $ + not $ scheduleMatches weekly (UTCTime (fromGregorian 2014 6 5) 600) + + it "only needs weekday or monthday to match" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1), + dayOfMonth = DaysOfMonth (SpecificField 1) } + (UTCTime (fromGregorian 2014 11 1) 600) + + prop "star matches everything" $ \t -> + scheduleMatches stars t + + prop "exact time matches" $ \t -> + let (_, m, d, h, mn) = timeComponents t + sched = CronSchedule (Minutes $ SpecificField mn) + (Hours $ SpecificField h) + (DaysOfMonth $ SpecificField d) + (Months $ SpecificField m) + (DaysOfWeek Star) + in scheduleMatches sched t + + prop "any time with the same minute as n * * * * matches" $ arbitraryTimeFields $ \y m d h mn -> + let sched = stars { minute = Minutes $ SpecificField mn } + t = day' y m d h mn + in scheduleMatches sched t + + prop "any time with the diff minute as n * * * * does not match" $ arbitraryTimeFields $ \y m d h mn -> + let sched = stars { minute = Minutes $ SpecificField $ stepMax 59 mn } + t = day' y m d h mn + in not $ scheduleMatches sched t + + prop "any time with the same hour as * n * * * matches" $ arbitraryTimeFields $ \y m d h mn -> + let sched = stars { hour = Hours $ SpecificField h } + t = day' y m d h mn + in scheduleMatches sched t + + prop "any time with the diff hour as * n * * * does not match" $ arbitraryTimeFields $ \y m d h mn -> + let sched = stars { hour = Hours $ SpecificField $ stepMax 23 h } + t = day' y m d h mn + in not $ scheduleMatches sched t + + prop "any time with the same day as * * n * * matches" $ \t -> + let (_, m, d, h, mn) = timeComponents t + sched = CronSchedule (Minutes $ SpecificField mn) + (Hours $ SpecificField h) + (DaysOfMonth $ SpecificField d) + (Months $ SpecificField m) + (DaysOfWeek Star) + in scheduleMatches sched t + + prop "any time with the diff day as * * n * * does not match" $ arbitraryTimeFields $ \y m d h mn -> + let sched = stars { dayOfMonth = DaysOfMonth $ SpecificField $ stepMax 31 d } + t = day' y m d h mn + in not $ scheduleMatches sched t + + where day = day' 2012 + day' y m d h mn = UTCTime (fromGregorian y m d) (diffTime h mn) + diffTime h mn = timeOfDayToTime $ TimeOfDay h mn 1 + +arbitraryTimeFields f y m d h mn = f (getPositive y) + (min 12 $ getPositive m) + (min 28 $ getPositive d) + (min 23 $ getPositive h) + (min 59 $ getPositive mn) + +hoursMins uTime = (hr, mn) + where + TimeOfDay { todHour = hr, + todMin = mn} = timeToTimeOfDay uTime + + +stepMax :: (Enum a, Ord a) => a -> a -> a +stepMax mx n | n < mx = succ n + | otherwise = pred n + + +describeCronScheduleShow :: Spec +describeCronScheduleShow = describe "CronSchedule show" $ do + it "formats stars" $ + show stars `shouldBe` + "CronSchedule * * * * *" + + it "formats specific numbers" $ + show stars { dayOfWeek = DaysOfWeek (SpecificField 3)} `shouldBe` + "CronSchedule * * * * 3" + + it "formats lists" $ + show stars { minute = Minutes (ListField [SpecificField 1, + SpecificField 2, + SpecificField 3])} `shouldBe` + "CronSchedule 1,2,3 * * * *" + + it "formats ranges" $ + show stars { hour = Hours (RangeField 7 10)} `shouldBe` + "CronSchedule * 7-10 * * *" + + it "formats steps" $ + show stars { dayOfMonth = DaysOfMonth (StepField (ListField [SpecificField 3, SpecificField 5]) 2)} `shouldBe` + "CronSchedule * * 3,5/2 * *" + + it "formats @yearly" $ + show yearly `shouldBe` "CronSchedule 0 0 1 1 *" + + it "formats @monthly" $ + show monthly `shouldBe` "CronSchedule 0 0 1 * *" + + it "formats @weekly" $ + show weekly `shouldBe` "CronSchedule 0 0 * * 0" + + it "formats @daily" $ + show daily `shouldBe` "CronSchedule 0 0 * * *" + + it "formats @hourly" $ + show hourly `shouldBe` "CronSchedule 0 * * * *" + + it "formats everyMinute" $ + show everyMinute `shouldBe` "CronSchedule * * * * *" + +describeCrontabShow :: Spec +describeCrontabShow = describe "Crontab Show" $ do + it "prints nothing for an empty crontab" $ + show (Crontab []) `shouldBe` "" + +describeCrontabEntryShow :: Spec +describeCrontabEntryShow = describe "CrontabEntry Show" $ do + it "formats environment variable sets" $ + show envSet `shouldBe` "FOO=BAR" + + it "formats command entries" $ + show entry `shouldBe` "* * * * * do stuff" + + +envSet :: CrontabEntry +envSet = EnvVariable "FOO" "BAR" + +entry :: CrontabEntry +entry = CommandEntry stars "do stuff" + +stars :: CronSchedule +stars = CronSchedule (Minutes Star) + (Hours Star) + (DaysOfMonth Star) + (Months Star) + (DaysOfWeek Star) + +timeComponents :: UTCTime -> (Integer, Int, Int, Int, Int) +timeComponents (UTCTime dy dt) = (y, m, d, h, mn) + where + (y, m, d) = toGregorian dy + (h, mn) = hoursMins dt