diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +# 0.3.2 +* Add test files to dist # 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 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -1,5 +1,5 @@ Name: cron -Version: 0.3.1 +Version: 0.3.2 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,6 +29,11 @@ README.md LICENSE changelog + test/Main.hs + test/SpecHelper.hs + test/System/Test/Cron.hs + test/System/Test/Cron/Parser.hs + test/System/Test/Cron/Schedule.hs Homepage: http://github.com/michaelxavier/cron Bug-Reports: http://github.com/michaelxavier/cron/issues diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 --- /dev/null +++ b/test/SpecHelper.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +module SpecHelper + ( module X + , isLeft + ) where + + +------------------------------------------------------------------------------- +import Control.Applicative as X +import Data.Attoparsec.Text as X +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 System.Cron as X +import System.Cron.Parser 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) + + +------------------------------------------------------------------------------- +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False diff --git a/test/System/Test/Cron.hs b/test/System/Test/Cron.hs new file mode 100644 --- /dev/null +++ b/test/System/Test/Cron.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE OverloadedStrings #-} +module System.Test.Cron (tests) where + +------------------------------------------------------------------------------- +import SpecHelper +------------------------------------------------------------------------------- + + +tests :: TestTree +tests = testGroup "System.Cron" + [ describeScheduleMatches + , describeCronScheduleShow + , describeCrontabEntryShow + , describeCrontabShow + ] + +---- Specs +describeScheduleMatches :: TestTree +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)} + (day 5 25 1 2) @?= True + + , testCase "matches a range" $ + scheduleMatches stars { dayOfMonth = DaysOfMonth (RangeField 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 + + , testCase "matches a step field" $ + scheduleMatches stars { dayOfMonth = DaysOfMonth (StepField (RangeField 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)} + (day 5 13 1 2) @?= False + + , testCase "matches starred stepped fields" $ + scheduleMatches stars { minute = Minutes (StepField 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)} + (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) } + (day 5 3 13 2) @?= True + + , testCase "matches a monday as 1" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 1) } + (UTCTime (fromGregorian 2014 3 17) 0) @?= True + + , testCase "matches a sunday as 0" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 0) } + (UTCTime (fromGregorian 2014 3 16) 0) @?= True + + , testCase "matches a sunday as 7" $ + scheduleMatches stars { dayOfWeek = DaysOfWeek (SpecificField 7) } + (UTCTime (fromGregorian 2014 3 16) 0) @?= True + + , testCase "matches weekly on a sunday at 0:00" $ + scheduleMatches weekly (UTCTime (fromGregorian 2014 4 6) 0) @?= True + + , testCase "does not match weekly on a sunday at some time past midnight" $ + scheduleMatches weekly (UTCTime (fromGregorian 2014 6 4) 600) @?= False + + , testCase "does not match weekly on another day at midnight" $ + 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) } + (UTCTime (fromGregorian 2014 11 1) 600) @?= True + -- https://github.com/MichaelXavier/cron/issues/18 + , testCase "correctly schedules steps and ranges" $ do + let Right oddMinute = parseOnly cronSchedule "1-59/2 * * * *" + let Right evenMinute = parseOnly cronSchedule "0-59/2 * * * *" + let t1 = mkTime 2015 7 17 15 17 0 + let t2 = mkTime 2015 7 17 15 18 0 + scheduleMatches oddMinute t1 @?= True + scheduleMatches oddMinute t2 @?= False + scheduleMatches evenMinute t1 @?= False + scheduleMatches evenMinute t2 @?= True + + , testProperty "star matches everything" $ \t -> + scheduleMatches stars t + + , 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) + 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 } + 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 } + 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 } + 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 } + 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) + 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 } + 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 :: TestTree +describeCronScheduleShow = testGroup "CronSchedule show" + [ + testCase "formats stars" $ + show stars @?= "CronSchedule * * * * *" + + , testCase "formats specific numbers" $ + show stars { dayOfWeek = DaysOfWeek (SpecificField 3)} @?= + "CronSchedule * * * * 3" + + , testCase "formats lists" $ + show stars { minute = Minutes (ListField [SpecificField 1, + SpecificField 2, + SpecificField 3])} @?= + "CronSchedule 1,2,3 * * * *" + + , testCase "formats ranges" $ + show stars { hour = Hours (RangeField 7 10)} @?= + "CronSchedule * 7-10 * * *" + + , testCase "formats steps" $ + show stars { dayOfMonth = DaysOfMonth (StepField (ListField [SpecificField 3, SpecificField 5]) 2)} @?= + "CronSchedule * * 3,5/2 * *" + + , testCase "formats @yearly" $ + show yearly @?= "CronSchedule 0 0 1 1 *" + + , testCase "formats @monthly" $ + show monthly @?= "CronSchedule 0 0 1 * *" + + , testCase "formats @weekly" $ + show weekly @?= "CronSchedule 0 0 * * 0" + + , testCase "formats @daily" $ + show daily @?= "CronSchedule 0 0 * * *" + + , testCase "formats @hourly" $ + show hourly @?= "CronSchedule 0 * * * *" + + , testCase "formats everyMinute" $ + show everyMinute @?= "CronSchedule * * * * *" + ] + +describeCrontabShow :: TestTree +describeCrontabShow = testGroup "Crontab Show" + [ + testCase "prints nothing for an empty crontab" $ + show (Crontab []) @?= "" + ] + +describeCrontabEntryShow :: TestTree +describeCrontabEntryShow = testGroup "CrontabEntry Show" + [ + testCase "formats environment variable sets" $ + show envSet @?= "FOO=BAR" + + , testCase "formats command entries" $ + show entry @?= "* * * * * 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 + + +mkTime y m d hr mn s = UTCTime day time + where day = fromGregorian y m d + time = s + 60 * mn + 60 * 60 * hr diff --git a/test/System/Test/Cron/Parser.hs b/test/System/Test/Cron/Parser.hs new file mode 100644 --- /dev/null +++ b/test/System/Test/Cron/Parser.hs @@ -0,0 +1,195 @@ +{-# 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 SpecHelper +import System.Cron +import System.Cron.Parser +------------------------------------------------------------------------------- + + +tests :: TestTree +tests = testGroup "System.Cron.Parser" + [ describeCronSchedule + , describeCronScheduleLoose + , describeCrontab + , describeCrontabEntry + ] + +describeCronSchedule :: TestTree +describeCronSchedule = testGroup "cronSchedule" + [ + testCase "parses all stars" $ + assertSuccessfulParse "* * * * *" + stars + + , testCase "parses specific values" $ + assertSuccessfulParse "1 2 3 * *" + stars { minute = Minutes (SpecificField 1), + hour = Hours (SpecificField 2), + dayOfMonth = DaysOfMonth (SpecificField 3) } + + , testCase "parses list values" $ + assertSuccessfulParse "* * 3,4 * *" + stars { dayOfMonth = DaysOfMonth (ListField [SpecificField 3, + SpecificField 4]) } + + , testCase "parses range values" $ + assertSuccessfulParse "* * 3-4 * *" + stars { dayOfMonth = DaysOfMonth (RangeField 3 4) } + + , testCase "parses step values" $ + assertSuccessfulParse "*/2 * 2-10/4 * *" + stars { minute = Minutes (StepField Star 2), + dayOfMonth = DaysOfMonth (StepField (RangeField 2 10) 4) } + + , testCase "refuses to parse recursive steps" $ + assertFailedParse "*/2/3 * * * *" + + , testCase "refuses to parse sparse lists" $ + assertFailedParse "1,,2 * * * *" + + , testCase "refuses too few fields" $ + assertFailedParse "* * * *" + + , testCase "refuses too many fields" $ + assertFailedParse "* * * * * *" + + , testCase "refuses extraneous input" $ + assertFailedParse "* * * * * wat is this" + + , testCase "parses @hourly" $ + assertSuccessfulParse "@hourly" hourly + + , testCase "parses @daily" $ + assertSuccessfulParse "@daily" daily + + , testCase "parses @monthly" $ + assertSuccessfulParse "@monthly" monthly + + , testCase "parses @yearly" $ + assertSuccessfulParse "@yearly" yearly + + , testCase "parses ranges at the last field" $ + assertSuccessfulParse "* * * * 3-4" + stars { dayOfWeek = DaysOfWeek (RangeField 3 4) } + , testCase "parses lists at the last field" $ + assertSuccessfulParse "* * * * 3,4" + stars { dayOfWeek = DaysOfWeek (ListField [SpecificField 3, + SpecificField 4]) } + , testCase "parses steps at the last field" $ + assertSuccessfulParse "* * * * */4" + stars { dayOfWeek = DaysOfWeek (StepField Star 4) } + , testCase "parses a sunday as 7" $ + assertSuccessfulParse "* * * * 7" + stars { dayOfWeek = DaysOfWeek (SpecificField 7) } + , testCase "parses a sunday as 0" $ + assertSuccessfulParse "* * * * 0" + stars { dayOfWeek = DaysOfWeek (SpecificField 0) } + , testCase "parses another example" $ + assertSuccessfulParse "1-59/2 * * * *" + stars { minute = Minutes (StepField (RangeField 1 59) 2) } + + ] + where assertSuccessfulParse = assertParse cronSchedule + assertFailedParse = assertNoParse cronSchedule + +describeCronScheduleLoose :: TestTree +describeCronScheduleLoose = testGroup "cronScheduleLoose" + [ + testCase "is okay with extaneous input" $ + assertSuccessfulParse "* * * * * *" + stars + ] + where assertSuccessfulParse = assertParse cronScheduleLoose + +describeCrontab :: TestTree +describeCrontab = testGroup "crontab" + [ + testCase "parses an empty input" $ + assertSuccessfulParse "" + (Crontab []) + + , testCase "parses whitespace" $ + assertSuccessfulParse " " + (Crontab []) + + , testCase "parses a single line" $ + assertSuccessfulParse " " + (Crontab []) + + , testCase "ignores comments" $ + assertSuccessfulParse "# comment" + (Crontab []) + + , testCase "ignores comments with leading whitespace" $ + assertSuccessfulParse " # comment" + (Crontab []) + + , testCase "parses comments interspersed with actual commands" $ + assertSuccessfulParse "#comment here\nFOO=BAR\n #another\n* * * * * do stuff" + (Crontab [envSet, entry]) + ] + where assertSuccessfulParse = assertParse crontab + +describeCrontabEntry :: TestTree +describeCrontabEntry = testGroup "crontabEntry" + [ + testCase "parses an environment variable assignment" $ + assertSuccessfulParse "FOO=BAR" + envSet + + , testCase "parses an environment variable with whitespace at the front" $ + assertSuccessfulParse " FOO=BAR" + envSet + + , testCase "parses an environment variable with whitespace in the middle" $ + assertSuccessfulParse " FOO = BAR" + envSet + + , testCase "parses a command" $ + assertSuccessfulParse "* * * * * do stuff" + entry + + , testCase "parses a command with any amount of whitespace inbetween" $ + assertSuccessfulParse "* * * * * do stuff" + entry + + , testCase "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 + -> Assertion +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" + +stars :: CronSchedule +stars = CronSchedule (Minutes Star) + (Hours Star) + (DaysOfMonth Star) + (Months Star) + (DaysOfWeek Star) diff --git a/test/System/Test/Cron/Schedule.hs b/test/System/Test/Cron/Schedule.hs new file mode 100644 --- /dev/null +++ b/test/System/Test/Cron/Schedule.hs @@ -0,0 +1,50 @@ +module System.Test.Cron.Schedule + ( tests + ) where + +------------------------------------------------------------------------------- +import Control.Concurrent +------------------------------------------------------------------------------- +import SpecHelper +import System.Cron.Schedule +------------------------------------------------------------------------------- + + +tests :: TestTree +tests = testGroup "System.Cron.Schedule" + [ describeMonadSchedule + , describeExecSchedule + ] + +flipMVar :: MVar String -> IO () +flipMVar v = putMVar v "dost thou even hoist" + +describeMonadSchedule :: TestTree +describeMonadSchedule = testGroup "MonadSchedule" + [ + testCase "should place the first job as the last job stated." $ + let (Job x _) = (s !! 0) + in show x @?= "CronSchedule 0 0 * * *" + , testCase "should place the last job as the first job stated." $ + let (Job x _) = (s !! 2) + in show x @?= "CronSchedule * * * * *" + , testCase "should read all three jobs." $ + length s @?= 3 + ] + where Right ((), s) = runSchedule $ do addJob empty "* * * * *" + addJob empty "0 * * * *" + addJob empty "0 0 * * *" + +describeExecSchedule :: TestTree +describeExecSchedule = testGroup "execSchedule" + [ + testCase "should set an mvar each minute" $ + fireAndWait >>= (@?= "dost thou even hoist") + ] + where fireAndWait = do + v <- newEmptyMVar + tids <- execSchedule $ do + addJob (flipMVar v) "* * * * *" + threadDelay (1000000 * 60) + mapM_ killThread tids + takeMVar v