diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +# 0.3.1 +* Fix bug that caused some range schedules to not fire at the correct time. See https://github.com/MichaelXavier/cron/issues/18 # 0.3.0 * MTL compatibility updates. # 0.2.6 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -1,5 +1,5 @@ Name: cron -Version: 0.3.0 +Version: 0.3.1 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 @@ -29,9 +29,6 @@ README.md LICENSE changelog - test/Spec.hs - test/System/Cron/ParserSpec.hs - test/System/CronSpec.hs Homepage: http://github.com/michaelxavier/cron Bug-Reports: http://github.com/michaelxavier/cron/issues @@ -49,25 +46,21 @@ mtl >= 2.0.1, mtl-compat >= 0.2.1 -test-suite spec +test-suite test Type: exitcode-stdio-1.0 - Main-Is: Spec.hs + Main-Is: Main.hs Hs-Source-Dirs: test - Other-Modules: SpecHelper - System.Cron.ParserSpec - System.Cron.ScheduleSpec - System.CronSpec - Build-Depends: base >= 4 && < 5, + Build-Depends: base >= 4 && < 5, cron, - hspec >= 1.3, - QuickCheck, + tasty, + tasty-hunit, + tasty-quickcheck, derive, - hspec-expectations, attoparsec >= 0.10, text >= 0.11 && < 2, time >= 1.4, transformers-compat >= 0.4 - Ghc-Options: -threaded -rtsopts + Ghc-Options: -threaded -rtsopts -with-rtsopts=-N 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 @@ -230,7 +230,9 @@ fillTo start finish step | step <= 0 = [] | finish < start = [] - | otherwise = [ x | x <- [start..finish], x `mod` step == 0] + | otherwise = takeWhile (<= finish) nums + where nums = map (start +) adds + adds = map (*2) [0..] data CronUnit = CMinute | CHour | 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 @@ -103,17 +103,27 @@ {- 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 +-- in the future. execSchedule :: Schedule () -> IO [ThreadId] execSchedule s = let res = runSchedule s in case res of Left e -> print e >> return [] Right (_, jobs) -> mapM forkJob jobs +-- | 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. forkJob :: Job -> IO ThreadId forkJob (Job s a) = forkIO $ forever $ do (timeAt, delay) <- findNextMinuteDelay threadDelay delay - when (scheduleMatches s timeAt) a + when (scheduleMatches s timeAt) (void $ forkIO a) findNextMinuteDelay :: IO (UTCTime, Int) findNextMinuteDelay = do diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,20 @@ +module Main + ( main + ) where + + + +------------------------------------------------------------------------------- +import SpecHelper +import qualified System.Test.Cron +import qualified System.Test.Cron.Parser +import qualified System.Test.Cron.Schedule +------------------------------------------------------------------------------- + + +main :: IO () +main = defaultMain $ testGroup "cron" + [ System.Test.Cron.tests + , System.Test.Cron.Parser.tests + , System.Test.Cron.Schedule.tests + ] diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs deleted file mode 100644 --- a/test/SpecHelper.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module SpecHelper (module X) where - -import Control.Applicative as X -import Data.DeriveTH -import Data.Time.Clock as X -import Data.Time.Calendar as X -import Data.Time.LocalTime as X -import Test.Hspec as X -import Test.Hspec.QuickCheck as X -import Test.QuickCheck as X - -import System.Cron as X - -import Debug.Trace as X - -instance Arbitrary UTCTime where - arbitrary = do - d <- ModifiedJulianDay . fromInteger . getPositive <$> arbitrary - t <- fromInteger . getPositive <$> arbitrary - return $ UTCTime d t - -$(derive makeArbitrary ''CronField) -$(derive makeArbitrary ''MinuteSpec) -$(derive makeArbitrary ''HourSpec) -$(derive makeArbitrary ''DayOfWeekSpec) -$(derive makeArbitrary ''DayOfMonthSpec) -$(derive makeArbitrary ''MonthSpec) -$(derive makeArbitrary ''CronSchedule) diff --git a/test/System/Cron/ParserSpec.hs b/test/System/Cron/ParserSpec.hs deleted file mode 100644 --- a/test/System/Cron/ParserSpec.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module System.Cron.ParserSpec (spec) where --- TODO: this *should* just work with {-# OPTIONS_GHC -F -pgmF hspec-discover #-} - -import Data.Attoparsec.Text (parseOnly, Parser) -import Data.Text (Text) -import Test.Hspec - -import System.Cron -import System.Cron.Parser -import Test.Hspec.Expectations.Contrib (isLeft) - -spec :: Spec -spec = sequence_ [describeCronSchedule, - describeCronScheduleLoose, - describeCrontab, - describeCrontabEntry] - -describeCronSchedule :: Spec -describeCronSchedule = describe "cronSchedule" $ do - it "parses all stars" $ - assertSuccessfulParse "* * * * *" - stars - - it "parses specific values" $ - assertSuccessfulParse "1 2 3 * *" - stars { minute = Minutes (SpecificField 1), - hour = Hours (SpecificField 2), - dayOfMonth = DaysOfMonth (SpecificField 3) } - - it "parses list values" $ - assertSuccessfulParse "* * 3,4 * *" - stars { dayOfMonth = DaysOfMonth (ListField [SpecificField 3, - SpecificField 4]) } - - it "parses range values" $ - assertSuccessfulParse "* * 3-4 * *" - stars { dayOfMonth = DaysOfMonth (RangeField 3 4) } - - it "parses step values" $ - assertSuccessfulParse "*/2 * 2-10/4 * *" - stars { minute = Minutes (StepField Star 2), - dayOfMonth = DaysOfMonth (StepField (RangeField 2 10) 4) } - - it "refuses to parse recursive steps" $ - assertFailedParse "*/2/3 * * * *" - - it "refuses to parse sparse lists" $ - assertFailedParse "1,,2 * * * *" - - it "refuses too few fields" $ - assertFailedParse "* * * *" - - it "refuses too many fields" $ - assertFailedParse "* * * * * *" - - it "refuses extraneous input" $ - assertFailedParse "* * * * * wat is this" - - it "parses @hourly" $ - assertSuccessfulParse "@hourly" hourly - - it "parses @daily" $ - assertSuccessfulParse "@daily" daily - - it "parses @monthly" $ - assertSuccessfulParse "@monthly" monthly - - it "parses @yearly" $ - assertSuccessfulParse "@yearly" yearly - - it "parses ranges at the last field" $ - assertSuccessfulParse "* * * * 3-4" - stars { dayOfWeek = DaysOfWeek (RangeField 3 4) } - it "parses lists at the last field" $ - assertSuccessfulParse "* * * * 3,4" - stars { dayOfWeek = DaysOfWeek (ListField [SpecificField 3, - SpecificField 4]) } - it "parses steps at the last field" $ - assertSuccessfulParse "* * * * */4" - stars { dayOfWeek = DaysOfWeek (StepField Star 4) } - it "parses a sunday as 7" $ - assertSuccessfulParse "* * * * 7" - stars { dayOfWeek = DaysOfWeek (SpecificField 7) } - it "parses a sunday as 0" $ - assertSuccessfulParse "* * * * 0" - stars { dayOfWeek = DaysOfWeek (SpecificField 0) } - where assertSuccessfulParse = assertParse cronSchedule - assertFailedParse = assertNoParse cronSchedule - -describeCronScheduleLoose :: Spec -describeCronScheduleLoose = describe "cronScheduleLoose" $ do - it "is okay with extaneous input" $ - assertSuccessfulParse "* * * * * *" - stars - where assertSuccessfulParse = assertParse cronScheduleLoose - -describeCrontab :: Spec -describeCrontab = describe "crontab" $ do - it "parses an empty input" $ - assertSuccessfulParse "" - (Crontab []) - - it "parses whitespace" $ - assertSuccessfulParse " " - (Crontab []) - - it "parses a single line" $ - assertSuccessfulParse " " - (Crontab []) - - it "ignores comments" $ - assertSuccessfulParse "# comment" - (Crontab []) - - it "ignores comments with leading whitespace" $ - assertSuccessfulParse " # comment" - (Crontab []) - - it "parses comments interspersed with actual commands" $ - assertSuccessfulParse "#comment here\nFOO=BAR\n #another\n* * * * * do stuff" - (Crontab [envSet, entry]) - - where assertSuccessfulParse = assertParse crontab - -describeCrontabEntry :: Spec -describeCrontabEntry = describe "crontabEntry" $ do - it "parses an environment variable assignment" $ - assertSuccessfulParse "FOO=BAR" - envSet - - it "parses an environment variable with whitespace at the front" $ - assertSuccessfulParse " FOO=BAR" - envSet - - it "parses an environment variable with whitespace in the middle" $ - assertSuccessfulParse " FOO = BAR" - envSet - - it "parses a command" $ - assertSuccessfulParse "* * * * * do stuff" - entry - - it "parses a command with any amount of whitespace inbetween" $ - assertSuccessfulParse "* * * * * do stuff" - entry - - it "parses a command with whitespace at the front" $ - assertSuccessfulParse " * * * * * do stuff" - entry - where assertSuccessfulParse = assertParse crontabEntry - -assertParse :: (Eq a, Show a) - => Parser a - -> Text - -> a - -> Expectation -assertParse parser txt expected = parsed `shouldBe` Right expected - where parsed = parseOnly parser txt - ---assertNoParse :: Parser a -> Text -> b -assertNoParse :: (Eq a, Show a) - => Parser a - -> Text - -> Expectation -assertNoParse parser txt = parseOnly parser txt `shouldSatisfy` isLeft - -envSet :: CrontabEntry -envSet = EnvVariable "FOO" "BAR" - -entry :: CrontabEntry -entry = CommandEntry stars "do stuff" - -stars :: CronSchedule -stars = CronSchedule (Minutes Star) - (Hours Star) - (DaysOfMonth Star) - (Months Star) - (DaysOfWeek Star) diff --git a/test/System/Cron/ScheduleSpec.hs b/test/System/Cron/ScheduleSpec.hs deleted file mode 100644 --- a/test/System/Cron/ScheduleSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -module System.Cron.ScheduleSpec - ( spec - ) where - -import Control.Concurrent -import Test.Hspec - -import System.Cron.Schedule - -spec :: Spec -spec = sequence_ [ describeMonadSchedule - , describeExecSchedule - ] - -empty :: IO () -empty = return () - -flipMVar :: MVar String -> IO () -flipMVar v = putMVar v "dost thou even hoist" - -describeMonadSchedule :: Spec -describeMonadSchedule = describe "MonadSchedule" $ do - let Right ((), s) = runSchedule (do addJob empty "* * * * *" - addJob empty "0 * * * *" - addJob empty "0 0 * * *") - it "should place the first job as the last job stated." $ - let (Job x _) = (s !! 0) - in show x `shouldBe` "CronSchedule 0 0 * * *" - it "should place the last job as the first job stated." $ - let (Job x _) = (s !! 2) - in show x `shouldBe` "CronSchedule * * * * *" - it "should read all three jobs." $ - length s `shouldBe` 3 - -describeExecSchedule :: Spec -describeExecSchedule = describe "execSchedule" $ do - it "should set an mvar each minute" $ - fireAndWait >>= (`shouldBe` "dost thou even hoist") - where fireAndWait = do - v <- newEmptyMVar - tids <- execSchedule $ do - addJob (flipMVar v) "* * * * *" - threadDelay (1000000 * 60) - mapM_ killThread tids - takeMVar v diff --git a/test/System/CronSpec.hs b/test/System/CronSpec.hs deleted file mode 100644 --- a/test/System/CronSpec.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module System.CronSpec (spec) where - -import SpecHelper - -spec :: Spec -spec = sequence_ [describeScheduleMatches, - describeCronScheduleShow, - describeCrontabEntryShow, - describeCrontabShow ] - ----- Specs -describeScheduleMatches :: Spec -describeScheduleMatches = describe "ScheduleMatches" $ do - it "matches a catch-all" $ - scheduleMatches stars (day 5 25 1 2) - - it "matches a specific field" $ - scheduleMatches stars { hour = Hours (SpecificField 1)} - (day 5 25 1 2) - - it "matches a range" $ - scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 3 5)} - (day 5 4 1 2) - - it "does not match invalid range" $ - not $ scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 5 3)} - (day 5 4 1 2) - - it "matches a list" $ - scheduleMatches stars { month = Months (ListField [SpecificField 1, - SpecificField 2, - SpecificField 3])} - (day 2 3 1 2) - - it "matches a step field" $ - scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 10 16) 2)} - (day 5 12 1 2) - - it "does not match something missing the step field" $ - not $ scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 10 16) 2)} - (day 5 13 1 2) - - it "matches starred stepped fields" $ - scheduleMatches stars { minute = Minutes (StepField Star 2)} - (day 5 13 1 4) - - it "does not match fields that miss starred stepped fields" $ - not $ scheduleMatches stars { minute = Minutes (StepField Star 2)} - (day 5 13 1 5) - - it "matches multiple fields at once" $ - scheduleMatches stars { minute = Minutes (StepField Star 2), - dayOfMonth = DaysOfMonth (SpecificField 3), - hour = Hours (RangeField 10 14) } - (day 5 3 13 2) - - it "matches a monday as 1" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1) } - (UTCTime (fromGregorian 2014 3 17) 0) - - it "matches a sunday as 0" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 0) } - (UTCTime (fromGregorian 2014 3 16) 0) - - it "matches a sunday as 7" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 7) } - (UTCTime (fromGregorian 2014 3 16) 0) - - it "matches weekly on a sunday at 0:00" $ - scheduleMatches weekly (UTCTime (fromGregorian 2014 4 6) 0) - - it "does not match weekly on a sunday at some time past midnight" $ - not $ scheduleMatches weekly (UTCTime (fromGregorian 2014 6 4) 600) - - it "does not match weekly on another day at midnight" $ - not $ scheduleMatches weekly (UTCTime (fromGregorian 2014 6 5) 600) - - it "only needs weekday or monthday to match" $ - scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1), - dayOfMonth = DaysOfMonth (SpecificField 1) } - (UTCTime (fromGregorian 2014 11 1) 600) - - prop "star matches everything" $ \t -> - scheduleMatches stars t - - prop "exact time matches" $ \t -> - let (_, m, d, h, mn) = timeComponents t - sched = CronSchedule (Minutes $ SpecificField mn) - (Hours $ SpecificField h) - (DaysOfMonth $ SpecificField d) - (Months $ SpecificField m) - (DaysOfWeek Star) - in scheduleMatches sched t - - prop "any time with the same minute as n * * * * matches" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { minute = Minutes $ SpecificField mn } - t = day' y m d h mn - in scheduleMatches sched t - - prop "any time with the diff minute as n * * * * does not match" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { minute = Minutes $ SpecificField $ stepMax 59 mn } - t = day' y m d h mn - in not $ scheduleMatches sched t - - prop "any time with the same hour as * n * * * matches" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { hour = Hours $ SpecificField h } - t = day' y m d h mn - in scheduleMatches sched t - - prop "any time with the diff hour as * n * * * does not match" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { hour = Hours $ SpecificField $ stepMax 23 h } - t = day' y m d h mn - in not $ scheduleMatches sched t - - prop "any time with the same day as * * n * * matches" $ \t -> - let (_, m, d, h, mn) = timeComponents t - sched = CronSchedule (Minutes $ SpecificField mn) - (Hours $ SpecificField h) - (DaysOfMonth $ SpecificField d) - (Months $ SpecificField m) - (DaysOfWeek Star) - in scheduleMatches sched t - - prop "any time with the diff day as * * n * * does not match" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { dayOfMonth = DaysOfMonth $ SpecificField $ stepMax 31 d } - t = day' y m d h mn - in not $ scheduleMatches sched t - - where day = day' 2012 - day' y m d h mn = UTCTime (fromGregorian y m d) (diffTime h mn) - diffTime h mn = timeOfDayToTime $ TimeOfDay h mn 1 - -arbitraryTimeFields f y m d h mn = f (getPositive y) - (min 12 $ getPositive m) - (min 28 $ getPositive d) - (min 23 $ getPositive h) - (min 59 $ getPositive mn) - -hoursMins uTime = (hr, mn) - where - TimeOfDay { todHour = hr, - todMin = mn} = timeToTimeOfDay uTime - - -stepMax :: (Enum a, Ord a) => a -> a -> a -stepMax mx n | n < mx = succ n - | otherwise = pred n - - -describeCronScheduleShow :: Spec -describeCronScheduleShow = describe "CronSchedule show" $ do - it "formats stars" $ - show stars `shouldBe` - "CronSchedule * * * * *" - - it "formats specific numbers" $ - show stars { dayOfWeek = DaysOfWeek (SpecificField 3)} `shouldBe` - "CronSchedule * * * * 3" - - it "formats lists" $ - show stars { minute = Minutes (ListField [SpecificField 1, - SpecificField 2, - SpecificField 3])} `shouldBe` - "CronSchedule 1,2,3 * * * *" - - it "formats ranges" $ - show stars { hour = Hours (RangeField 7 10)} `shouldBe` - "CronSchedule * 7-10 * * *" - - it "formats steps" $ - show stars { dayOfMonth = DaysOfMonth (StepField (ListField [SpecificField 3, SpecificField 5]) 2)} `shouldBe` - "CronSchedule * * 3,5/2 * *" - - it "formats @yearly" $ - show yearly `shouldBe` "CronSchedule 0 0 1 1 *" - - it "formats @monthly" $ - show monthly `shouldBe` "CronSchedule 0 0 1 * *" - - it "formats @weekly" $ - show weekly `shouldBe` "CronSchedule 0 0 * * 0" - - it "formats @daily" $ - show daily `shouldBe` "CronSchedule 0 0 * * *" - - it "formats @hourly" $ - show hourly `shouldBe` "CronSchedule 0 * * * *" - - it "formats everyMinute" $ - show everyMinute `shouldBe` "CronSchedule * * * * *" - -describeCrontabShow :: Spec -describeCrontabShow = describe "Crontab Show" $ do - it "prints nothing for an empty crontab" $ - show (Crontab []) `shouldBe` "" - -describeCrontabEntryShow :: Spec -describeCrontabEntryShow = describe "CrontabEntry Show" $ do - it "formats environment variable sets" $ - show envSet `shouldBe` "FOO=BAR" - - it "formats command entries" $ - show entry `shouldBe` "* * * * * do stuff" - - -envSet :: CrontabEntry -envSet = EnvVariable "FOO" "BAR" - -entry :: CrontabEntry -entry = CommandEntry stars "do stuff" - -stars :: CronSchedule -stars = CronSchedule (Minutes Star) - (Hours Star) - (DaysOfMonth Star) - (Months Star) - (DaysOfWeek Star) - -timeComponents :: UTCTime -> (Integer, Int, Int, Int, Int) -timeComponents (UTCTime dy dt) = (y, m, d, h, mn) - where - (y, m, d) = toGregorian dy - (h, mn) = hoursMins dt