cron 0.3.2 → 0.4.0

raw patch · 12 files changed

+1352/−447 lines, 12 filesdep +criteriondep +quickcheck-instancesdep +semigroupsdep ~attoparsecdep ~basedep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, quickcheck-instances, semigroups

Dependency ranges changed: attoparsec, base, text, time, transformers-compat

API changes (from Hackage documentation)

Files

• bench/Main.hs +107/−0
• changelog +3/−0
• cron.cabal +67/−25
• src/System/Cron.hs +15/−246
• src/System/Cron/Internal/Check.hs +274/−0
• src/System/Cron/Parser.hs +144/−59
• src/System/Cron/Schedule.hs +42/−12
• src/System/Cron/Types.hs +399/−0
• test/SpecHelper.hs +109/−23
• test/System/Test/Cron.hs +137/−53
• test/System/Test/Cron/Parser.hs +55/−28
• test/System/Test/Cron/Schedule.hs +0/−1

@@ -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

@@ -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

@@ -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

@@ -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 <michael@michaelxavier.net>--- 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+-------------------------------------------------------------------------------

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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   -------------------------------------------------------------------------------

@@ -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

@@ -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

@@ -6,7 +6,6 @@ import           Control.Concurrent ------------------------------------------------------------------------------- import           SpecHelper-import           System.Cron.Schedule -------------------------------------------------------------------------------