cron 0.3.0 → 0.3.1

raw patch · 10 files changed

+44/−495 lines, 10 filesdep +tastydep +tasty-hunitdep +tasty-quickcheckdep −QuickCheckdep −hspecdep −hspec-expectationsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: QuickCheck, hspec, hspec-expectations

API changes (from Hackage documentation)

Files

• changelog +2/−0
• cron.cabal +8/−15
• src/System/Cron.hs +3/−1
• src/System/Cron/Schedule.hs +11/−1
• test/Main.hs +20/−0
• test/Spec.hs +0/−1
• test/SpecHelper.hs +0/−29
• test/System/Cron/ParserSpec.hs +0/−179
• test/System/Cron/ScheduleSpec.hs +0/−45
• test/System/CronSpec.hs +0/−224

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

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

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

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

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

@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}

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

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

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

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