diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Criterion +import Criterion.Main +import Data.Attoparsec.Text (Parser, parseOnly) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +------------------------------------------------------------------------------- +import System.Cron +------------------------------------------------------------------------------- + + +main :: IO () +main = defaultMain + [ parserBenchmarks + , scheduleMatchesBenchmarks + , nextMatchBenchmarks + , serializeBenchmarks + ] + + +------------------------------------------------------------------------------- +parserBenchmarks :: Benchmark +parserBenchmarks = bgroup "parsers" + [ parserBench "cronSchedule" cronSchedule cronScheduleText + , parserBench "cronScheduleLoose" cronScheduleLoose cronScheduleText + , parserBench "crontab" crontab cronTabText + , bgroup "crontabEntry" + [ parserBench "schedule" crontabEntry cronScheduleText + , parserBench "env set" crontabEntry envSetText + ] + ] + + +------------------------------------------------------------------------------- +scheduleMatchesBenchmarks :: Benchmark +scheduleMatchesBenchmarks = bgroup "scheduleMatches" + [ + bench "match" (whnf (scheduleMatches weekly) matchingTime) + , bench "no match" (whnf (scheduleMatches weekly) nonMatchingTime) + ] + where + matchingTime = mkTime 2016 2 14 0 0 0 + nonMatchingTime = mkTime 2016 2 15 0 0 0 + + +------------------------------------------------------------------------------- +nextMatchBenchmarks :: Benchmark +nextMatchBenchmarks = + bench "nextMatch" (whnf (nextMatch weekly) now) + where + now = mkTime 2016 2 14 0 0 0 + +------------------------------------------------------------------------------- +serializeBenchmarks :: Benchmark +serializeBenchmarks = bgroup "serialization" + [ + bench "cronSchedule" (whnf serializeCronSchedule weekly) + , bench "crontab" (whnf serializeCrontab exampleCrontab) + ] + + +------------------------------------------------------------------------------- +parserBench :: String -> Parser a -> Text -> Benchmark +parserBench n parser txt = bench n (whnf (parseOnly parser) txt) + + +------------------------------------------------------------------------------- +cronScheduleText :: Text +cronScheduleText = "*/2 * 3 * 4,5,6" + + +------------------------------------------------------------------------------- +envSetText :: Text +envSetText = "FOO=BAR" + +------------------------------------------------------------------------------- +cronTabText :: Text +cronTabText = T.unlines (concat (zipWith (\x y -> [x,y]) (replicate 50 cronScheduleText) (repeat envSetText))) + + +------------------------------------------------------------------------------- +exampleCrontab :: Crontab +exampleCrontab = Crontab (concat (zipWith (\x y -> [x,y]) (replicate 50 cmd) (repeat envSet))) + where + cmd = CommandEntry weekly (CronCommand "do something") + envSet = EnvVariable "FOO" "BAR" + + +------------------------------------------------------------------------------- +mkTime + :: Integer + -> Int + -> Int + -> DiffTime + -> DiffTime + -> DiffTime + -> UTCTime +mkTime y m d hr mn s = UTCTime day time + where day = fromGregorian y m d + time = s + 60 * mn + 60 * 60 * hr diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +# 0.4.0 +* Various type changes to make it impossible to construct invalid cron schedules. +* Add nextMatch function for non-polling based schedulers. # 0.3.2 * Add test files to dist # 0.3.1 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -1,5 +1,5 @@ Name: cron -Version: 0.3.2 +Version: 0.4.0 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 @@ -24,7 +24,7 @@ , GHC == 7.6.3 , GHC == 7.8.3 , GHC == 7.10.1 -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Extra-Source-Files: README.md LICENSE @@ -37,35 +37,77 @@ Homepage: http://github.com/michaelxavier/cron Bug-Reports: http://github.com/michaelxavier/cron/issues +flag lib-Werror + default: False + manual: True + 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.0.1, - mtl-compat >= 0.2.1 + Exposed-modules: System.Cron + , System.Cron.Internal.Check + , System.Cron.Parser + , System.Cron.Schedule + , System.Cron.Types + Hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4 && < 5 + , attoparsec >= 0.10 + , text >= 0.11 && < 2 + , time >= 1.4 + , old-locale >= 1.0 + , mtl >= 2.0.1 + , mtl-compat >= 0.2.1 + , semigroups + if flag(lib-Werror) + ghc-options: -Werror + ghc-options: -Wall + + test-suite test Type: exitcode-stdio-1.0 Main-Is: Main.hs Hs-Source-Dirs: test - Build-Depends: base >= 4 && < 5, - cron, - tasty, - tasty-hunit, - tasty-quickcheck, - derive, - attoparsec >= 0.10, - text >= 0.11 && < 2, - time >= 1.4, - transformers-compat >= 0.4 - Ghc-Options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + other-modules: SpecHelper + , System.Test.Cron + , System.Test.Cron.Parser + , System.Test.Cron.Schedule + Build-Depends: base + , cron + , tasty + , tasty-hunit + , tasty-quickcheck + , derive + , attoparsec + , text + , time + , transformers-compat + , semigroups + , quickcheck-instances + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + default-language: Haskell2010 + build-depends: + base + , cron + , criterion + , text + , attoparsec + , time + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall source-repository head Type: git diff --git a/src/System/Cron.hs b/src/System/Cron.hs --- a/src/System/Cron.hs +++ b/src/System/Cron.hs @@ -1,248 +1,17 @@ --------------------------------------------------------------------- --- | --- 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 +{-# LANGUAGE RecordWildCards #-} +--TODO: internal module, quickcheck +module System.Cron + ( module System.Cron.Types + , module System.Cron.Parser + , module System.Cron.Schedule + , scheduleMatches + , nextMatch + ) where --- | 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 = takeWhile (<= finish) nums - where nums = map (start +) adds - adds = map (*2) [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 +------------------------------------------------------------------------------- +import System.Cron.Internal.Check +import System.Cron.Parser +import System.Cron.Schedule +import System.Cron.Types +------------------------------------------------------------------------------- diff --git a/src/System/Cron/Internal/Check.hs b/src/System/Cron/Internal/Check.hs new file mode 100644 --- /dev/null +++ b/src/System/Cron/Internal/Check.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE RecordWildCards #-} +module System.Cron.Internal.Check where + +------------------------------------------------------------------------------- +import qualified Data.Foldable as FT +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Semigroup (sconcat) +import Data.Time +import Data.Time.Calendar.WeekDate +import qualified Data.Traversable as FT +------------------------------------------------------------------------------- +import System.Cron.Types +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- Schedule projection +------------------------------------------------------------------------------- + + +-- | Will return the next time from the given starting point where +-- this schedule will match. Returns Nothing if the schedule will +-- never match. Note that this function is not inclusive of the given +-- time: the result will always be at least 1 minute beyond the given +-- time. This is usually used to implement absolute timestamp +-- schedulers. If you need to see multiple matches ahead, just keep +-- feeding the result into nextMatch. Note that because nextMatch only +-- returns Nothing on a schedule that will *never* be matched, it is +-- safe to assume that if a schedule returns a Just once, it will +-- always return a Just. +nextMatch :: CronSchedule -> UTCTime -> Maybe UTCTime +nextMatch cs@CronSchedule {..} now + | domRestricted && dowRestricted = do + -- this trick is courtesy of Python's croniter: run the schedule + -- once with * in the DOM spot and once with * in the DOW slot + -- and then choose the earlier of the two. + domStarSpec <- mkDayOfMonthSpec (Field Star) + dowStarSpec <- mkDayOfWeekSpec (Field Star) + let domStarResult = nextMatch cs { dayOfMonth = domStarSpec } now + let dowStarResult = nextMatch cs { dayOfWeek = dowStarSpec} now + listToMaybe (sort (catMaybes [domStarResult, dowStarResult])) + | otherwise = do + expanded@Expanded {..} <- expand cs + let daysSource = validDays monthF domF startDay + listToMaybe (nextMatches daysSource expanded now) + where + UTCTime startDay _ = addUTCTime 60 now + domRestricted = restricted (dayOfMonthSpec dayOfMonth) + dowRestricted = restricted (dayOfWeekSpec dayOfWeek) + + +------------------------------------------------------------------------------- +nextMatches :: [Day] -> Expanded -> UTCTime -> [UTCTime] +nextMatches daysSource Expanded {..} now = solutions + where + -- move to next minute + solutions = filter validSolution [UTCTime d tod + | d <- daysSource + , tod <- validTODs hourF minF + ] + validSolution t = t > now && dowMatch t dowF + + +------------------------------------------------------------------------------- +dowMatch :: UTCTime -> EField -> Bool +dowMatch (UTCTime d _) dows = (getDOW d `elem` dows) + + +------------------------------------------------------------------------------- +-- | ISO8601 maps Sunday as 7 and Monday as 1, we want Sunday as 0 +getDOW :: Day -> Int +getDOW d + | iso8601DOW == 7 = 0 + | otherwise = iso8601DOW + where + (_, _, iso8601DOW) = toWeekDate d + + +------------------------------------------------------------------------------- +validDays :: EField -> EField -> Day -> [Day] +validDays months days start = + concat (firstYearDates:subsequentYearDates) + where + (startYear, startMonth, _) = toGregorian start + firstYearMonths = dropWhile (< startMonth) subsequentYearMonths + subsequentYearMonths = sortBy compare (FT.toList months) + firstYearDates = dateSequence firstYearMonths startYear + subsequentYearDates = [ dateSequence subsequentYearMonths y | y <- [startYear+1..]] + dateSequence mseq y = catMaybes [fromGregorianValid y m d + | m <- mseq + , d <- sortBy compare (FT.toList days)] + + +------------------------------------------------------------------------------- +-- | Guarantees: the Expanded will be satisfiable (no invalid dates, +-- no empties). dow 7 will be normalized to 0 (Sunday) +expand :: CronSchedule -> Maybe Expanded +expand CronSchedule {..} = do + expanded <- Expanded <$> minF' + <*> hourF' + <*> domF' + <*> monthF' + <*> dowF' + if satisfiable expanded + then Just expanded + else Nothing + where + minF' = expandF (0, 59) (minuteSpec minute) + hourF' = expandF (0, 23) (hourSpec hour) + domF' = expandF (1, 31) (dayOfMonthSpec dayOfMonth) + monthF' = expandF (1, 12) (monthSpec month) + dowF' = remapSunday <$> expandF (0, 7) (dayOfWeekSpec dayOfWeek) + remapSunday lst = case NE.partition (\n -> n == 0 || n == 7) lst of + ([], _) -> lst + (_, noSunday) -> 0 :| noSunday + domRestricted = restricted (dayOfMonthSpec dayOfMonth) + dowRestricted = restricted (dayOfWeekSpec dayOfWeek) + -- If DOM and DOW are restricted, they are ORed, so even if + -- there's an invalid day for the month, it is still satisfiable + -- because it will just choose the DOW path + satisfiable Expanded {..} = (domRestricted && dowRestricted) || + or [hasValidForMonth m domF | m <- (FT.toList monthF)] + + +------------------------------------------------------------------------------- +expandF :: (Int, Int) -> CronField -> Maybe EField +expandF rng (Field f) = expandBF rng f +expandF rng (ListField fs) = NE.nub . sconcat <$> FT.mapM (expandBF rng) fs +expandF rng (StepField' sf) = expandBFStepped rng (sfField sf) (sfStepping sf) + + +------------------------------------------------------------------------------- +expandBFStepped :: (Int, Int) -> BaseField -> Int -> Maybe EField +expandBFStepped rng Star step = NE.nonEmpty (fillTo rng step) +expandBFStepped (_, unitMax) (RangeField' rf) step = NE.nonEmpty (fillTo (start, finish') step) + where + finish' = min finish unitMax + start = rfBegin rf + finish = rfEnd rf +expandBFStepped (_, unitMax) (SpecificField' sf) step = + expandBFStepped (startAt, unitMax) Star step + where + startAt = specificField sf + + +------------------------------------------------------------------------------- +fillTo :: (Int, Int) + -> Int + -> [Int] +fillTo (start, finish) step + | step <= 0 = [] + | finish < start = [] + | otherwise = takeWhile (<= finish) nums + where + nums = [ start + (step * iter) | iter <- [0..]] + + +------------------------------------------------------------------------------- +expandBF :: (Int, Int) -> BaseField -> Maybe EField +expandBF (lo, hi) Star = Just (NE.fromList (enumFromTo lo hi)) +expandBF _ (SpecificField' sf) = Just (specificField sf :| []) +expandBF _ (RangeField' rf) = Just (NE.fromList (enumFromTo (rfBegin rf) (rfEnd rf))) + + +------------------------------------------------------------------------------- +validTODs :: EField -> EField -> [DiffTime] +validTODs hrs mns = dtSequence + where + minuteSequence = sortBy compare (FT.toList mns) + hourSequence = sortBy compare (FT.toList hrs) + -- order here ensures we'll count up minutes before hours + dtSequence = [ todToDiffTime hr mn | hr <- hourSequence, mn <- minuteSequence] + + +------------------------------------------------------------------------------- +todToDiffTime :: Int -> Int -> DiffTime +todToDiffTime nextHour nextMin = fromIntegral ((nextHour * 60 * 60) + nextMin * 60) + + +------------------------------------------------------------------------------- +timeOfDay :: DiffTime -> (Int, Int) +timeOfDay t = (h, m) + where + seconds = floor t + minutes = seconds `div` 60 + (h, m) = minutes `divMod` 60 + + +------------------------------------------------------------------------------- +hasValidForMonth + :: Int + -- ^ Month + -> EField + -> Bool +hasValidForMonth 1 days = minimum days <= 31 +hasValidForMonth 2 days = minimum days <= 29 +hasValidForMonth 3 days = minimum days <= 31 +hasValidForMonth 4 days = minimum days <= 30 +hasValidForMonth 5 days = minimum days <= 31 +hasValidForMonth 6 days = minimum days <= 30 +hasValidForMonth 7 days = minimum days <= 31 +hasValidForMonth 8 days = minimum days <= 31 +hasValidForMonth 9 days = minimum days <= 30 +hasValidForMonth 10 days = minimum days <= 31 +hasValidForMonth 11 days = minimum days <= 30 +hasValidForMonth 12 days = minimum days <= 31 +hasValidForMonth _ _ = False + + +------------------------------------------------------------------------------- +data Expanded = Expanded { + minF :: EField + , hourF :: EField + , domF :: EField + , monthF :: EField + , dowF :: EField + } deriving (Show) + + +------------------------------------------------------------------------------- +-- This could be an intmap but I'm not convinced there's significant +-- performance to be gained +type EField = NonEmpty Int + + + +-- | Does the given cron schedule match for the given timestamp? This +-- is usually used for implementing polling-type schedulers like cron +-- itself. +scheduleMatches + :: CronSchedule + -> UTCTime + -> Bool +scheduleMatches cs@CronSchedule {..} (UTCTime d t) = + maybe False go (expand cs) + where + go Expanded {..} = and + [ FT.elem mn minF + , FT.elem hr hourF + , FT.elem mth monthF + , checkDOMAndDOW + ] + where + -- turns out if neither dom and dow are stars, you're supposed to + -- OR and not AND them: + -- + -- Note: The day of a command's execution can + -- be specified by two fields — day of month, and day of week. If + -- both fields are restricted (i.e., aren't *), the command will + -- be run when either field matches the current time. For example, + -- ``30 4 1,15 * 5'' would cause a command to be run at 4:30 am on + -- the 1st and 15th of each month, plus every Friday. One can, + -- however, achieve the desired result by adding a test to the + -- command (see the last example in EXAMPLE CRON FILE below). + checkDOMAndDOW + | restricted (dayOfMonthSpec dayOfMonth) && restricted (dayOfWeekSpec dayOfWeek) = + domMatches || dowMatches + | otherwise = domMatches && dowMatches + domMatches = FT.elem dom domF + dowMatches = FT.elem dow dowF + (_, mth, dom) = toGregorian d + (hr, mn) = timeOfDay t + dow = getDOW d + + +restricted :: CronField -> Bool +restricted = not . isStar + +isStar :: CronField -> Bool +isStar (Field Star) = True +isStar _ = False diff --git a/src/System/Cron/Parser.hs b/src/System/Cron/Parser.hs --- a/src/System/Cron/Parser.hs +++ b/src/System/Cron/Parser.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -------------------------------------------------------------------- -- | -- Module : System.Cron.Parser @@ -12,32 +11,38 @@ -- -- 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" --- +-- > main = don +-- > print $ parseCronSchedule "*/2 * 3 * 4,5,6" +-- -------------------------------------------------------------------- -module System.Cron.Parser (cronSchedule, - cronScheduleLoose, - crontab, - crontabEntry) where - -import System.Cron +module System.Cron.Parser + ( -- * Parsers + cronSchedule + , cronScheduleLoose + , crontab + , crontabEntry + -- * Convenience Functions + , parseCronSchedule + , parseCrontab + , parseCrontabEntry + ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (*>), (<$>), (<*), (<*>), (<|>)) -#else -import Control.Applicative ((<$>), (<|>)) -#endif -import Data.Char (isSpace) +------------------------------------------------------------------------------- +import Control.Applicative as Ap import Data.Attoparsec.Text (Parser) import qualified Data.Attoparsec.Text as A -import Data.Text (Text) +import Data.Char (isSpace) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +------------------------------------------------------------------------------- +import System.Cron.Types +------------------------------------------------------------------------------- + -- | 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 @@ -47,6 +52,8 @@ cronSchedule :: Parser CronSchedule cronSchedule = cronScheduleLoose <* A.endOfInput + +------------------------------------------------------------------------------- -- | Same as 'cronSchedule' but does not fail on extraneous input. cronScheduleLoose :: Parser CronSchedule cronScheduleLoose = yearlyP <|> @@ -56,6 +63,8 @@ hourlyP <|> classicP + +------------------------------------------------------------------------------- -- | Parses a full crontab file, omitting comments and including environment -- variable sets (e.g FOO=BAR). crontab :: Parser Crontab @@ -63,6 +72,8 @@ 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 @@ -77,15 +88,43 @@ A.skipWhile (\c -> c == ' ' || c == '\t') return $ EnvVariable var val commandEntryP = CommandEntry <$> cronScheduleLoose - <*> (A.skipSpace *> takeToEOL) + <*> (A.skipSpace *> (CronCommand <$> takeToEOL)) ----- Internals + +------------------------------------------------------------------------------- +-- Convenience functions +------------------------------------------------------------------------------- + + +parseCronSchedule :: Text -> Either String CronSchedule +parseCronSchedule = A.parseOnly cronSchedule + + +------------------------------------------------------------------------------- +parseCrontab :: Text -> Either String Crontab +parseCrontab = A.parseOnly crontab + + +------------------------------------------------------------------------------- +parseCrontabEntry :: Text -> Either String CrontabEntry +parseCrontabEntry = A.parseOnly crontabEntry + + +------------------------------------------------------------------------------- +-- 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) @@ -94,72 +133,118 @@ <*> dayOfWeekP where space = A.char ' ' + +------------------------------------------------------------------------------- cronFieldP :: Parser CronField -cronFieldP = steppedP <|> - rangeP <|> - listP <|> - starP <|> +cronFieldP = stepP <|> + listP <|> + fieldP + + where + fieldP = Field <$> baseFieldP + listP = ListField <$> neListP baseFieldP + stepP = StepField' <$> stepFieldP + + +------------------------------------------------------------------------------- +stepFieldP :: Parser StepField +stepFieldP = do + f <- baseFieldP + _ <- A.char '/' + mParse (mkStepField f) "invalid stepping" =<< parseInt + + +------------------------------------------------------------------------------- +neListP :: Parser a -> Parser (NonEmpty a) +neListP p = coerceNE =<< A.sepBy1 p (A.char ',') + where + coerceNE [] = fail "expected non-empty list" + coerceNE [_] = fail "invalid singleton list" + coerceNE (x:xs) = return $ x :| xs + + +------------------------------------------------------------------------------- +baseFieldP :: Parser BaseField +baseFieldP = rangeP <|> + 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 + where starP = A.char '*' *> Ap.pure Star + rangeP = RangeField' <$> rangeFieldP + specificP = SpecificField' <$> specificFieldP + +------------------------------------------------------------------------------- +specificFieldP :: Parser SpecificField +specificFieldP = + mParse mkSpecificField "specific field value out of range" =<< parseInt + + +------------------------------------------------------------------------------- +rangeFieldP :: Parser RangeField +rangeFieldP = do + begin <- parseInt + + + _ <- A.char '-' + end <- parseInt + mParse (mkRangeField begin) "start of range must be less than or equal to end" end + + +------------------------------------------------------------------------------- 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 +minutesP = mParse mkMinuteSpec "minutes out of range" =<< cronFieldP + +------------------------------------------------------------------------------- hoursP :: Parser HourSpec -hoursP = Hours <$> cronFieldP +hoursP = mParse mkHourSpec "hours out of range" =<< cronFieldP + +------------------------------------------------------------------------------- dayOfMonthP :: Parser DayOfMonthSpec -dayOfMonthP = DaysOfMonth <$> cronFieldP +dayOfMonthP = mParse mkDayOfMonthSpec "day of month out of range" =<< cronFieldP + +------------------------------------------------------------------------------- monthP :: Parser MonthSpec -monthP = Months <$> cronFieldP +monthP = mParse mkMonthSpec "month out of range" =<< cronFieldP + +------------------------------------------------------------------------------- dayOfWeekP :: Parser DayOfWeekSpec -dayOfWeekP = DaysOfWeek <$> cronFieldP +dayOfWeekP = mParse mkDayOfWeekSpec "day of week out of range" =<< cronFieldP + +------------------------------------------------------------------------------- parseInt :: Parser Int parseInt = A.decimal -reduceList :: [CronField] -> CronField -reduceList [] = ListField [] -- this should not happen -reduceList [x] = x -reduceList xs = ListField xs + +------------------------------------------------------------------------------- +mParse :: (Monad m) => (a -> Maybe b) -> String -> a -> m b +mParse f msg = maybe (fail msg) return . f diff --git a/src/System/Cron/Schedule.hs b/src/System/Cron/Schedule.hs --- a/src/System/Cron/Schedule.hs +++ b/src/System/Cron/Schedule.hs @@ -1,8 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - -------------------------------------------------------------------- -- | -- Module : System.Cron.Schedule @@ -44,6 +43,8 @@ , execSchedule ) where + +------------------------------------------------------------------------------- #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif @@ -51,15 +52,20 @@ import Control.Monad.Except import Control.Monad.Identity import Control.Monad.State -import Data.Attoparsec.Text (parseOnly) -import Data.Text (pack) +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 +------------------------------------------------------------------------------- +import System.Cron.Internal.Check +import System.Cron.Parser +import System.Cron.Types +------------------------------------------------------------------------------- + + readTime' :: TimeLocale -> String -> String -> UTCTime #if MIN_VERSION_time(1,5,0) readTime' = parseTimeOrError True @@ -67,31 +73,47 @@ readTime' = readTime #endif -{- Scheduleing monad -} +------------------------------------------------------------------------------- +-- | Scheduling 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 () @@ -101,13 +123,17 @@ Left e -> throwError $ ParseError e Right t' -> put $ Job t' a : s -{- Monitoring Engine -} --- | Schedule all of the jobs to run at appropriate intervals. Each --- job that is launched gets a scheduling thread to itself. Each +------------------------------------------------------------------------------- +-- Monitoring engine +------------------------------------------------------------------------------- + + +-- | Schedule all of the jobs to run at appropriate intervals. Each +-- job that is launched gets a scheduling thread to itself. Each -- time a scheduling thread launches a job, the job is forked onto -- a new thread. This means that if a job throws an excpetion in IO, --- its thread will be killed, but it will continue to be scheduled +-- its thread will be killed, but it will continue to be scheduled -- in the future. execSchedule :: Schedule () -> IO [ThreadId] execSchedule s = let res = runSchedule s @@ -115,7 +141,9 @@ Left e -> print e >> return [] Right (_, jobs) -> mapM forkJob jobs --- | Start a job-runner thread that runs a job at appropriate + +------------------------------------------------------------------------------- +-- | Start a job-runner thread that runs a job at appropriate -- intervals. Each time it is run, a new thread is forked for it, -- meaning that a single exception does not take down the -- scheduler. @@ -125,6 +153,8 @@ threadDelay delay when (scheduleMatches s timeAt) (void $ forkIO a) + +------------------------------------------------------------------------------- findNextMinuteDelay :: IO (UTCTime, Int) findNextMinuteDelay = do now <- getCurrentTime diff --git a/src/System/Cron/Types.hs b/src/System/Cron/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Cron/Types.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module System.Cron.Types + ( CronSchedule(..) + , Crontab(..) + , CrontabEntry(..) + , MinuteSpec + , CronCommand(..) + , minuteSpec + , mkMinuteSpec + , HourSpec + , hourSpec + , mkHourSpec + , MonthSpec + , monthSpec + , mkMonthSpec + , DayOfMonthSpec + , dayOfMonthSpec + , mkDayOfMonthSpec + , DayOfWeekSpec + , dayOfWeekSpec + , mkDayOfWeekSpec + , BaseField(..) + , SpecificField + , specificField + , mkSpecificField + , RangeField + , rfBegin + , rfEnd + , mkRangeField + , CronField(..) + , StepField + , sfField + , sfStepping + , mkStepField + -- * Commonly Used Schedules + , yearly + , monthly + , daily + , weekly + , hourly + , everyMinute + -- * Rendering + , serializeCronSchedule + , serializeCrontab + ) where + + +------------------------------------------------------------------------------- +import qualified Data.Foldable as FT +import Data.Ix +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- Shorthand schedules +------------------------------------------------------------------------------- + + +-- | Shorthand for every January 1st at midnight. Parsed with \@yearly, 0 0 1 1 * +yearly :: CronSchedule +yearly = monthly { month = Months (Field (SpecificField' (SpecificField 1))) } + + +-- | Shorthand for every 1st of the month at midnight. Parsed with \@monthly, 0 0 1 * * +monthly :: CronSchedule +monthly = daily { dayOfMonth = DaysOfMonth (Field (SpecificField' (SpecificField 1))) } + + +-- | Shorthand for every sunday at midnight. Parsed with \@weekly, 0 0 * * 0 +weekly :: CronSchedule +weekly = daily { dayOfWeek = DaysOfWeek (Field (SpecificField' (SpecificField 0))) } + + +-- | Shorthand for every day at midnight. Parsed with \@daily, 0 0 * * * +daily :: CronSchedule +daily = hourly { hour = Hours (Field (SpecificField' (SpecificField 0))) } + + +-- | Shorthand for every hour on the hour. Parsed with \@hourly, 0 * * * * +hourly :: CronSchedule +hourly = everyMinute { minute = Minutes (Field (SpecificField' (SpecificField 0))) } + + +-- | Shorthand for an expression that always matches. Parsed with * * * * * +everyMinute :: CronSchedule +everyMinute = CronSchedule { + minute = Minutes (Field Star) + , hour = Hours (Field Star) + , dayOfMonth = DaysOfMonth (Field Star) + , month = Months (Field Star) + , dayOfWeek = DaysOfWeek (Field Star) + } + + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + + +class ShowT a where + showT :: a -> Text + + +instance ShowT Text where + showT = id + + +instance ShowT Int where + showT = T.pack . show + + +-- | 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 " <> T.unpack (showT cs) + + +instance ShowT CronSchedule where + showT CronSchedule {..} = T.unwords [ showT minute + , showT hour + , showT dayOfMonth + , showT month + , showT dayOfWeek + ] + +serializeCronSchedule :: CronSchedule -> Text +serializeCronSchedule = showT + + +------------------------------------------------------------------------------- +-- | Crontab file, omitting comments. +newtype Crontab = Crontab { + crontabEntries :: [CrontabEntry] + } deriving (Eq) + + +instance ShowT Crontab where + showT (Crontab entries) = T.intercalate "\n" (showT <$> entries) + + +instance Show Crontab where + show = T.unpack . showT + + +serializeCrontab :: Crontab -> Text +serializeCrontab = showT + + +------------------------------------------------------------------------------- +newtype CronCommand = CronCommand { + cronCommand :: Text + } deriving (Show, Eq, Ord, ShowT) + + +------------------------------------------------------------------------------- +-- | 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 CronSchedule CronCommand + | EnvVariable Text Text + deriving (Eq) + + +instance ShowT CrontabEntry where + showT (CommandEntry s c) = showT s <> " " <> showT c + showT (EnvVariable n v) = showT n <> "=" <> showT v + + +instance Show CrontabEntry where + show = T.unpack . showT + +------------------------------------------------------------------------------- +-- | Minutes field of a cron expression +newtype MinuteSpec = Minutes { + minuteSpec :: CronField + } deriving (Eq, ShowT) + + +instance Show MinuteSpec where + show (Minutes cf) = show cf + + +--TODO: qc all of these +mkMinuteSpec :: CronField -> Maybe MinuteSpec +mkMinuteSpec cf + | validCF cf 0 59 = Just (Minutes cf) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +-- | Hours field of a cron expression +newtype HourSpec = Hours { + hourSpec :: CronField + } deriving (Eq, ShowT) + + +instance Show HourSpec where + show (Hours cf) = show cf + + +mkHourSpec :: CronField -> Maybe HourSpec +mkHourSpec cf + | validCF cf 0 23 = Just (Hours cf) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +-- | Day of month field of a cron expression +newtype DayOfMonthSpec = DaysOfMonth { + dayOfMonthSpec :: CronField + } deriving (Eq, ShowT) + + +instance Show DayOfMonthSpec where + show (DaysOfMonth cf) = show cf + + +mkDayOfMonthSpec :: CronField -> Maybe DayOfMonthSpec +mkDayOfMonthSpec cf + | validCF cf 1 31 = Just (DaysOfMonth cf) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +-- | Month field of a cron expression +newtype MonthSpec = Months { + monthSpec :: CronField + } deriving (Eq, ShowT) + + +instance Show MonthSpec where + show (Months cf) = show cf + + +mkMonthSpec :: CronField -> Maybe MonthSpec +mkMonthSpec cf + | validCF cf 1 12 = Just (Months cf) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +-- | Day of week field of a cron expression +newtype DayOfWeekSpec = DaysOfWeek { + dayOfWeekSpec :: CronField + } deriving (Eq, ShowT) + + +instance Show DayOfWeekSpec where + show (DaysOfWeek cf) = show cf + + +mkDayOfWeekSpec :: CronField -> Maybe DayOfWeekSpec +mkDayOfWeekSpec cf + -- 0-7 is a matter of some debate but we'll be liberal here + | validCF cf 0 7 = Just (DaysOfWeek cf) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +validCF + :: CronField + -> Int + -- ^ Min value + -> Int + -- ^ Max value + -> Bool +validCF (Field bf) mn mx = validBF bf mn mx +validCF (ListField bfs) mn mx = FT.all (\bf -> validBF bf mn mx) bfs +validCF (StepField' (StepField bf step)) mn mx = validBF bf mn mx && inRange (mn, mx) step + + +------------------------------------------------------------------------------- +validBF + :: BaseField + -> Int + -- ^ Min value + -> Int + -- ^ Max value + -> Bool +validBF Star _ _ = True +validBF (SpecificField' (SpecificField n)) mn mx = + inRange (mn, mx) n +validBF (RangeField' (RangeField n1 n2)) mn mx = + inRange (mn, mx) n1 && inRange (mn, mx) n2 + + +------------------------------------------------------------------------------- +-- | Individual field of a cron expression. +data BaseField = Star -- ^ Matches anything + | SpecificField' SpecificField -- ^ Matches a specific value (e.g. 1) + | RangeField' RangeField -- ^ Matches a range of values (e.g. 1-3) + deriving (Eq) + + +instance ShowT BaseField where + showT Star = "*" + showT (SpecificField' f) = showT f + showT (RangeField' rf) = showT rf + + +instance Show BaseField where + show = T.unpack . showT + + +------------------------------------------------------------------------------- +newtype SpecificField = SpecificField { + specificField :: Int + } deriving (Eq, ShowT) + + +instance Show SpecificField where + show = T.unpack . showT + + +mkSpecificField :: Int -> Maybe SpecificField +mkSpecificField n + | n >= 0 = Just (SpecificField n) + | otherwise = Nothing + + +------------------------------------------------------------------------------- +data RangeField = RangeField { + rfBegin :: Int + , rfEnd :: Int + } deriving (Eq) + + +instance ShowT RangeField where + showT (RangeField x y) = showT x <> "-" <> showT y + + +instance Show RangeField where + show = T.unpack . showT + + +mkRangeField :: Int -> Int -> Maybe RangeField +mkRangeField x y + | x <= y = Just (RangeField x y) + | otherwise = Nothing + + + +------------------------------------------------------------------------------- +data CronField = Field BaseField + | ListField (NonEmpty BaseField) -- ^ Matches a list of expressions. + | StepField' StepField -- ^ Matches a stepped expression, e.g. (*/2). + + +instance Eq CronField where + Field a == Field b = a == b + Field a == ListField (b :| []) = a == b + ListField as == ListField bs = as == bs + ListField (a :| []) == Field b = a == b + StepField' a == StepField' b = a == b + _ == _ = False + + +instance ShowT CronField where + showT (Field f) = showT f + showT (ListField xs) = T.intercalate "," (NE.toList (showT <$> xs)) + showT (StepField' sf) = showT sf + + +instance Show CronField where + show = T.unpack . showT + + +------------------------------------------------------------------------------- +data StepField = StepField { sfField :: BaseField + , sfStepping :: Int + } deriving (Eq) + + +instance ShowT StepField where + showT (StepField f step) = showT f <> "/" <> showT step + + +instance Show StepField where + show = T.unpack . showT + + +mkStepField :: BaseField -> Int -> Maybe StepField +mkStepField bf n + | n > 0 = Just (StepField bf n) + | otherwise = Nothing diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,40 +1,126 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} module SpecHelper ( module X - , isLeft + , module SpecHelper ) where ------------------------------------------------------------------------------- -import Control.Applicative as X -import Data.Attoparsec.Text as X +import Control.Applicative as X +import Data.Attoparsec.Text as X (Parser, parseOnly) import Data.DeriveTH -import Data.Time.Calendar as X -import Data.Time.Clock as X -import Data.Time.LocalTime as X -import Debug.Trace as X -import Test.Tasty as X -import Test.Tasty.HUnit as X -import Test.Tasty.QuickCheck as X +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe as X +import Data.Monoid as X +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar as X +import Data.Time.Clock as X +import Data.Time.LocalTime as X +import Debug.Trace as X +import Test.QuickCheck.Instances () +import Test.Tasty as X +import Test.Tasty.HUnit as X +import Test.Tasty.QuickCheck as X ------------------------------------------------------------------------------- -import System.Cron as X -import System.Cron.Parser as X +import System.Cron as X ------------------------------------------------------------------------------- -instance Arbitrary UTCTime where - arbitrary = do - d <- ModifiedJulianDay . fromInteger . getPositive <$> arbitrary - t <- fromInteger . getPositive <$> arbitrary - return $ UTCTime d t - +$(derive makeArbitrary ''NonEmpty) +$(derive makeArbitrary ''BaseField) $(derive makeArbitrary ''CronField) -$(derive makeArbitrary ''MinuteSpec) -$(derive makeArbitrary ''HourSpec) -$(derive makeArbitrary ''DayOfWeekSpec) -$(derive makeArbitrary ''DayOfMonthSpec) -$(derive makeArbitrary ''MonthSpec) $(derive makeArbitrary ''CronSchedule) + + +instance Arbitrary Crontab where + arbitrary = Crontab <$> resize 20 arbitrary + + +instance Arbitrary CronCommand where + arbitrary = CronCommand <$> alphaGen + + +instance Arbitrary CrontabEntry where + arbitrary = oneof [ CommandEntry <$> arbitrary <*> arbitrary + , EnvVariable <$> alphaGen <*> alphaGen + ] + + +alphaGen :: Gen Text +alphaGen = T.pack <$> listOf1 gen + where + gen = elements (['a'..'z'] <> ['A'..'Z']) + +instance Arbitrary MinuteSpec where + arbitrary = arbitraryMaybe mkMinuteSpec + + +instance Arbitrary HourSpec where + arbitrary = arbitraryMaybe mkHourSpec + + +instance Arbitrary DayOfMonthSpec where + arbitrary = arbitraryMaybe mkDayOfMonthSpec + + +instance Arbitrary MonthSpec where + arbitrary = arbitraryMaybe mkMonthSpec + + +instance Arbitrary DayOfWeekSpec where + arbitrary = arbitraryMaybe mkDayOfWeekSpec + + +instance Arbitrary SpecificField where + arbitrary = arbitraryMaybe mkSpecificField + + +instance Arbitrary RangeField where + arbitrary = arbitraryMaybe (uncurry mkRangeField) + + +instance Arbitrary StepField where + arbitrary = arbitraryMaybe (uncurry mkStepField) + + +arbitraryMaybe :: Arbitrary a => (a -> Maybe b) -> Gen b +arbitraryMaybe f = do + a <- arbitrary `suchThat` (isJust . f) + return (fromJust (f a)) + + +mkMinuteSpec' :: CronField -> MinuteSpec +mkMinuteSpec' = fromJust . mkMinuteSpec + + +mkHourSpec' :: CronField -> HourSpec +mkHourSpec' = fromJust . mkHourSpec + + +mkDayOfMonthSpec' :: CronField -> DayOfMonthSpec +mkDayOfMonthSpec' = fromJust . mkDayOfMonthSpec + + +mkMonthSpec' :: CronField -> MonthSpec +mkMonthSpec' = fromJust . mkMonthSpec + + +mkDayOfWeekSpec' :: CronField -> DayOfWeekSpec +mkDayOfWeekSpec' = fromJust . mkDayOfWeekSpec + + +mkRangeField' :: Int -> Int -> RangeField +mkRangeField' a = fromJust . mkRangeField a + + +mkSpecificField' :: Int -> SpecificField +mkSpecificField' = fromJust . mkSpecificField + + +mkStepField' :: BaseField -> Int -> StepField +mkStepField' a = fromJust . mkStepField a ------------------------------------------------------------------------------- diff --git a/test/System/Test/Cron.hs b/test/System/Test/Cron.hs --- a/test/System/Test/Cron.hs +++ b/test/System/Test/Cron.hs @@ -2,6 +2,10 @@ module System.Test.Cron (tests) where ------------------------------------------------------------------------------- +import Data.List (find) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Time.Clock.POSIX +------------------------------------------------------------------------------- import SpecHelper ------------------------------------------------------------------------------- @@ -12,65 +16,60 @@ , describeCronScheduleShow , describeCrontabEntryShow , describeCrontabShow + , describeNextMatch ] ----- Specs + describeScheduleMatches :: TestTree -describeScheduleMatches = testGroup "ScheduleMatches" +describeScheduleMatches = testGroup "scheduleMatches" [ testCase "matches a catch-all" $ scheduleMatches stars (day 5 25 1 2) @?= True , testCase "matches a specific field" $ - scheduleMatches stars { hour = Hours (SpecificField 1)} + scheduleMatches stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' 1)))} (day 5 25 1 2) @?= True , testCase "matches a range" $ - scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 3 5)} + scheduleMatches stars { dayOfMonth = mkDayOfMonthSpec' (Field (RangeField' (mkRangeField' 3 5)))} (day 5 4 1 2) @?= True - , testCase "does not match invalid range" $ - scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 5 3)} - (day 5 4 1 2) @?= False - , testCase "matches a list" $ - scheduleMatches stars { month = Months (ListField [SpecificField 1, - SpecificField 2, - SpecificField 3])} - (day 2 3 1 2) @?= True + scheduleMatches stars { month = mkMonthSpec' (ListField (SpecificField' (mkSpecificField' 1) :| [SpecificField' (mkSpecificField' 2), SpecificField' (mkSpecificField' 3)]))} + (day 2 3 1 2) @?= True , testCase "matches a step field" $ - scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 10 16) 2)} + scheduleMatches stars { dayOfMonth = mkDayOfMonthSpec' (StepField' (mkStepField' (RangeField' (mkRangeField' 10 16)) 2))} (day 5 12 1 2) @?= True , testCase "does not match something missing the step field" $ - scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 10 16) 2)} + scheduleMatches stars { dayOfMonth = mkDayOfMonthSpec' (StepField' (mkStepField' (RangeField' (mkRangeField' 10 16)) 2))} (day 5 13 1 2) @?= False , testCase "matches starred stepped fields" $ - scheduleMatches stars { minute = Minutes (StepField Star 2)} + scheduleMatches stars { minute = mkMinuteSpec' (StepField' (mkStepField' Star 2))} (day 5 13 1 4) @?= True , testCase "does not match fields that miss starred stepped fields" $ - scheduleMatches stars { minute = Minutes (StepField Star 2)} + scheduleMatches stars { minute = mkMinuteSpec' (StepField' (mkStepField' Star 2))} (day 5 13 1 5) @?= False , testCase "matches multiple fields at once" $ - scheduleMatches stars { minute = Minutes (StepField Star 2), - dayOfMonth = DaysOfMonth (SpecificField 3), - hour = Hours (RangeField 10 14) } + scheduleMatches stars { minute = mkMinuteSpec' (StepField' (mkStepField' Star 2)), + dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' 3))), + hour = mkHourSpec' (Field (RangeField' (mkRangeField' 10 14))) } (day 5 3 13 2) @?= True , testCase "matches a monday as 1" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1) } + scheduleMatches stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 1))) } (UTCTime (fromGregorian 2014 3 17) 0) @?= True , testCase "matches a sunday as 0" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 0) } + scheduleMatches stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 0))) } (UTCTime (fromGregorian 2014 3 16) 0) @?= True , testCase "matches a sunday as 7" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 7) } + scheduleMatches stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 7))) } (UTCTime (fromGregorian 2014 3 16) 0) @?= True , testCase "matches weekly on a sunday at 0:00" $ @@ -83,8 +82,19 @@ scheduleMatches weekly (UTCTime (fromGregorian 2014 6 5) 600) @?= False , testCase "only needs weekday or monthday to match" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1), - dayOfMonth = DaysOfMonth (SpecificField 1) } + -- man 5 crontab: + -- Note: The day of a command's execution can be specified by two + -- fields — day of month, and day of week. If both fields are + -- restricted (i.e., aren't *), the command will be run when either + -- field matches the current time. For example, ``30 4 1,15 * 5'' + -- would cause a command to be run at 4:30 am on the 1st and 15th of + -- each month, plus every Friday. One can, however, achieve the + -- desired result by adding a test to the command (see the last + -- example in EXAMPLE CRON FILE below). + -- + -- so we deliberately set the correct day of month but wrong day of week + scheduleMatches stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 1))), + dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' 1))) } (UTCTime (fromGregorian 2014 11 1) 600) @?= True -- https://github.com/MichaelXavier/cron/issues/18 , testCase "correctly schedules steps and ranges" $ do @@ -102,44 +112,44 @@ , testProperty "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) + sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn)))) + (mkHourSpec' (Field (SpecificField' (mkSpecificField' h)))) + (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d)))) + (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m)))) + (mkDayOfWeekSpec' (Field Star)) in scheduleMatches sched t , testProperty "any time with the same minute as n * * * * matches" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { minute = Minutes $ SpecificField mn } + let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))) } t = day' y m d h mn in scheduleMatches sched t , testProperty "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 } + let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' (stepMax 59 mn)))) } t = day' y m d h mn in not $ scheduleMatches sched t , testProperty "any time with the same hour as * n * * * matches" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { hour = Hours $ SpecificField h } + let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' h))) } t = day' y m d h mn in scheduleMatches sched t , testProperty "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 } + let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' (stepMax 23 h)))) } t = day' y m d h mn in not $ scheduleMatches sched t , testProperty "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) + sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn)))) + (mkHourSpec' (Field (SpecificField' (mkSpecificField' h)))) + (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d)))) + (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m)))) + (mkDayOfWeekSpec' (Field Star)) in scheduleMatches sched t , testProperty "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 } + let sched = stars { dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' (stepMax 31 d)))) } t = day' y m d h mn in not $ scheduleMatches sched t @@ -149,12 +159,30 @@ day' y m d h mn = UTCTime (fromGregorian y m d) (diffTime h mn) diffTime h mn = timeOfDayToTime $ TimeOfDay h mn 1 +arbitraryTimeFields + :: (Num r + , Num r1 + , Num r2 + , Num r3 + , Ord r + , Ord r1 + , Ord r2 + , Ord r3 + ) + => (a -> r -> r1 -> r2 -> r3 -> t) + -> Positive a + -> Positive r + -> Positive r1 + -> Positive r2 + -> Positive r3 + -> t 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 :: DiffTime -> (Int, Int) hoursMins uTime = (hr, mn) where TimeOfDay { todHour = hr, @@ -173,22 +201,20 @@ show stars @?= "CronSchedule * * * * *" , testCase "formats specific numbers" $ - show stars { dayOfWeek = DaysOfWeek (SpecificField 3)} @?= + show stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 3)))} @?= "CronSchedule * * * * 3" , testCase "formats lists" $ - show stars { minute = Minutes (ListField [SpecificField 1, - SpecificField 2, - SpecificField 3])} @?= - "CronSchedule 1,2,3 * * * *" + show stars { minute = mkMinuteSpec' (ListField (SpecificField' (mkSpecificField' 1) :| [SpecificField' (mkSpecificField' 2), SpecificField' (mkSpecificField' 3)]))} @?= + "CronSchedule 1,2,3 * * * *" , testCase "formats ranges" $ - show stars { hour = Hours (RangeField 7 10)} @?= + show stars { hour = mkHourSpec' (Field (RangeField' (mkRangeField' 7 10)))} @?= "CronSchedule * 7-10 * * *" , testCase "formats steps" $ - show stars { dayOfMonth = DaysOfMonth (StepField (ListField [SpecificField 3, SpecificField 5]) 2)} @?= - "CronSchedule * * 3,5/2 * *" + show stars { dayOfMonth = mkDayOfMonthSpec' (StepField' (mkStepField' Star 2))} @?= + "CronSchedule * * */2 * *" , testCase "formats @yearly" $ show yearly @?= "CronSchedule 0 0 1 1 *" @@ -227,18 +253,68 @@ ] +describeNextMatch :: TestTree +describeNextMatch = testGroup "nextMatch" + [ testProperty "is always in the future (at least 1 minute advanced)" $ \cs t -> + let tSecs = floor (utcTimeToPOSIXSeconds t) :: Integer + minT2 = posixSecondsToUTCTime (fromInteger ((tSecs `div` 60) + 1) * 60) + in case nextMatch cs t of + Just t2 -> t2 >= minT2 + Nothing -> True + , testProperty "always produces a time that will match the schedule" $ \cs t -> + case nextMatch cs t of + Just t2 -> counterexample (show t2 <> " does not match " <> show cs) (scheduleMatches cs t2) + Nothing -> property True + -- , testCase "special case" $ do + -- let Right cs = parseOnly cronSchedule "* * * * *" + -- t = mkTime 1858 11 20 0 0 1 + -- nextMatch cs t @?= Just (mkTime 1858 11 20 0 1 0) + -- this test has a really variable workload but is usually quite slow because it has to walk minute by minute until it finds the test case, so we'll set an upper bound here + , localOption (QuickCheckTests 20) $ testProperty "returns the first minute in the future that matches" $ \cs t -> + case nextMatch cs t of + Just res -> + let Just actual = find (scheduleMatches cs) ((takeWhile (<= res) (nextMinutes t))) + in res `sameMinute` actual + Nothing -> property True + , testProperty "a schedule that produces Just for one t will produce it for any t" $ \cs t1 t2 -> isJust (nextMatch cs t1) ==> + counterexample ("nextMatch produced Just for " <> show t1 <> " but not " <> show t2) + (isJust (nextMatch cs t2) == True) + ] + + +sameMinute :: UTCTime -> UTCTime -> Property +sameMinute t1 t2 = t1' === t2' + where + t1' = t1 { utctDayTime = roundToMinute (utctDayTime t1)} + t2' = t2 { utctDayTime = roundToMinute (utctDayTime t2)} + +nextMinutes :: UTCTime -> [UTCTime] +nextMinutes t = [ addMinutes tRounded mins | mins <- [1..]] + where + addMinutes time mins = addUTCTime (fromInteger (60 * mins)) time + -- round down to nearest 60 + tRounded = t { utctDayTime = roundToMinute (utctDayTime t)} + + + +roundToMinute :: DiffTime -> DiffTime +roundToMinute n = secondsToDiffTime (nInt - (nInt `mod` 60)) + where + nInt = round n + + envSet :: CrontabEntry envSet = EnvVariable "FOO" "BAR" entry :: CrontabEntry -entry = CommandEntry stars "do stuff" +entry = CommandEntry stars (CronCommand "do stuff") stars :: CronSchedule -stars = CronSchedule (Minutes Star) - (Hours Star) - (DaysOfMonth Star) - (Months Star) - (DaysOfWeek Star) +stars = CronSchedule (mkMinuteSpec' (Field Star)) + (mkHourSpec' (Field Star)) + (mkDayOfMonthSpec' (Field Star)) + (mkMonthSpec' (Field Star)) + (mkDayOfWeekSpec' (Field Star)) timeComponents :: UTCTime -> (Integer, Int, Int, Int, Int) timeComponents (UTCTime dy dt) = (y, m, d, h, mn) @@ -247,6 +323,14 @@ (h, mn) = hoursMins dt +mkTime + :: Integer + -> Int + -> Int + -> DiffTime + -> DiffTime + -> DiffTime + -> UTCTime mkTime y m d hr mn s = UTCTime day time where day = fromGregorian y m d time = s + 60 * mn + 60 * 60 * hr diff --git a/test/System/Test/Cron/Parser.hs b/test/System/Test/Cron/Parser.hs --- a/test/System/Test/Cron/Parser.hs +++ b/test/System/Test/Cron/Parser.hs @@ -1,15 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module System.Test.Cron.Parser (tests) where --- TODO: this *should* just work with {-# OPTIONS_GHC -F -pgmF hspec-discover #-} - ------------------------------------------------------------------------------- -import Data.Attoparsec.Text (Parser, parseOnly) -import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) ------------------------------------------------------------------------------- import SpecHelper -import System.Cron -import System.Cron.Parser ------------------------------------------------------------------------------- @@ -19,8 +15,12 @@ , describeCronScheduleLoose , describeCrontab , describeCrontabEntry + , describeSerializeParseCronSchedule + , describeSerializeParseCrontab ] + +------------------------------------------------------------------------------- describeCronSchedule :: TestTree describeCronSchedule = testGroup "cronSchedule" [ @@ -30,23 +30,22 @@ , testCase "parses specific values" $ assertSuccessfulParse "1 2 3 * *" - stars { minute = Minutes (SpecificField 1), - hour = Hours (SpecificField 2), - dayOfMonth = DaysOfMonth (SpecificField 3) } + stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' 1))), + hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' 2))), + dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' 3))) } , testCase "parses list values" $ assertSuccessfulParse "* * 3,4 * *" - stars { dayOfMonth = DaysOfMonth (ListField [SpecificField 3, - SpecificField 4]) } + stars { dayOfMonth = mkDayOfMonthSpec' (ListField (SpecificField' (mkSpecificField' 3) :| [SpecificField' (mkSpecificField' 4)])) } , testCase "parses range values" $ assertSuccessfulParse "* * 3-4 * *" - stars { dayOfMonth = DaysOfMonth (RangeField 3 4) } + stars { dayOfMonth = mkDayOfMonthSpec' (Field (RangeField' (mkRangeField' 3 4))) } , testCase "parses step values" $ assertSuccessfulParse "*/2 * 2-10/4 * *" - stars { minute = Minutes (StepField Star 2), - dayOfMonth = DaysOfMonth (StepField (RangeField 2 10) 4) } + stars { minute = mkMinuteSpec' (StepField' (mkStepField' Star 2)), + dayOfMonth = mkDayOfMonthSpec' (StepField' (mkStepField' (RangeField' (mkRangeField' 2 10)) 4)) } , testCase "refuses to parse recursive steps" $ assertFailedParse "*/2/3 * * * *" @@ -77,28 +76,29 @@ , testCase "parses ranges at the last field" $ assertSuccessfulParse "* * * * 3-4" - stars { dayOfWeek = DaysOfWeek (RangeField 3 4) } + stars { dayOfWeek = mkDayOfWeekSpec' (Field (RangeField' (mkRangeField' 3 4))) } , testCase "parses lists at the last field" $ assertSuccessfulParse "* * * * 3,4" - stars { dayOfWeek = DaysOfWeek (ListField [SpecificField 3, - SpecificField 4]) } + stars { dayOfWeek = mkDayOfWeekSpec' (ListField (SpecificField' (mkSpecificField' 3) :| [SpecificField' (mkSpecificField' 4)])) } , testCase "parses steps at the last field" $ assertSuccessfulParse "* * * * */4" - stars { dayOfWeek = DaysOfWeek (StepField Star 4) } + stars { dayOfWeek = mkDayOfWeekSpec' (StepField' (mkStepField' Star 4)) } , testCase "parses a sunday as 7" $ assertSuccessfulParse "* * * * 7" - stars { dayOfWeek = DaysOfWeek (SpecificField 7) } + stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 7))) } , testCase "parses a sunday as 0" $ assertSuccessfulParse "* * * * 0" - stars { dayOfWeek = DaysOfWeek (SpecificField 0) } + stars { dayOfWeek = mkDayOfWeekSpec' (Field (SpecificField' (mkSpecificField' 0))) } , testCase "parses another example" $ assertSuccessfulParse "1-59/2 * * * *" - stars { minute = Minutes (StepField (RangeField 1 59) 2) } + stars { minute = mkMinuteSpec' (StepField' (mkStepField' (RangeField' (mkRangeField' 1 59)) 2)) } ] where assertSuccessfulParse = assertParse cronSchedule assertFailedParse = assertNoParse cronSchedule + +------------------------------------------------------------------------------- describeCronScheduleLoose :: TestTree describeCronScheduleLoose = testGroup "cronScheduleLoose" [ @@ -108,6 +108,8 @@ ] where assertSuccessfulParse = assertParse cronScheduleLoose + +------------------------------------------------------------------------------- describeCrontab :: TestTree describeCrontab = testGroup "crontab" [ @@ -137,6 +139,8 @@ ] where assertSuccessfulParse = assertParse crontab + +------------------------------------------------------------------------------- describeCrontabEntry :: TestTree describeCrontabEntry = testGroup "crontabEntry" [ @@ -166,6 +170,26 @@ ] where assertSuccessfulParse = assertParse crontabEntry + +------------------------------------------------------------------------------- +describeSerializeParseCronSchedule :: TestTree +describeSerializeParseCronSchedule = testGroup "serialize/parse CronSchedule" + [ + testProperty "roundtrips" $ \cs -> do + parseCronSchedule (serializeCronSchedule cs) === Right cs + ] + + +------------------------------------------------------------------------------- +describeSerializeParseCrontab :: TestTree +describeSerializeParseCrontab = testGroup "serialize/parse Crontab" + [ + testProperty "roundtrips" $ \ct -> do + parseCrontab (serializeCrontab ct) === Right ct + ] + + +------------------------------------------------------------------------------- assertParse :: (Eq a, Show a) => Parser a -> Text @@ -174,22 +198,25 @@ assertParse parser txt expected = parsed @?= Right expected where parsed = parseOnly parser txt ---assertNoParse :: Parser a -> Text -> b + +------------------------------------------------------------------------------- assertNoParse :: (Eq a, Show a) => Parser a -> Text -> Assertion assertNoParse parser txt = isLeft (parseOnly parser txt) @?= True + +------------------------------------------------------------------------------- envSet :: CrontabEntry envSet = EnvVariable "FOO" "BAR" + +------------------------------------------------------------------------------- entry :: CrontabEntry -entry = CommandEntry stars "do stuff" +entry = CommandEntry stars (CronCommand "do stuff") + +------------------------------------------------------------------------------- stars :: CronSchedule -stars = CronSchedule (Minutes Star) - (Hours Star) - (DaysOfMonth Star) - (Months Star) - (DaysOfWeek Star) +stars = everyMinute diff --git a/test/System/Test/Cron/Schedule.hs b/test/System/Test/Cron/Schedule.hs --- a/test/System/Test/Cron/Schedule.hs +++ b/test/System/Test/Cron/Schedule.hs @@ -6,7 +6,6 @@ import Control.Concurrent ------------------------------------------------------------------------------- import SpecHelper -import System.Cron.Schedule -------------------------------------------------------------------------------