cron-compat (empty) → 0.2.6
raw patch · 13 files changed
+1195/−0 lines, 13 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed
Dependencies added: QuickCheck, attoparsec, base, cron, derive, hspec, hspec-expectations, mtl, mtl-compat, old-locale, text, time, transformers, transformers-compat
Files
- LICENSE +25/−0
- README.md +58/−0
- Setup.lhs +3/−0
- changelog +12/−0
- cron-compat.cabal +76/−0
- src/System/Cron.hs +246/−0
- src/System/Cron/Parser.hs +165/−0
- src/System/Cron/Schedule.hs +132/−0
- test/Spec.hs +1/−0
- test/SpecHelper.hs +29/−0
- test/System/Cron/ParserSpec.hs +179/−0
- test/System/Cron/ScheduleSpec.hs +45/−0
- test/System/CronSpec.hs +224/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2012, Michael Xavier. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,58 @@+cron+====+[](http://travis-ci.org/MichaelXavier/cron)++Cron data structure and Attoparsec parser for Haskell. The idea is to embed it+in larger systems which want to roll their own scheduled tasks in a format that+people are used to.++`System.Cron` is where all the interesting datatypes live. You will also find+`scheduleMatches`, which you can use to compare a time against a `CronSchedule`+to see if an action needs to be performed. System.Cron.Parser is where you will+find the parsers `cronSchedule`, `crontabEntry` and `cronTab`. To parse+individual schedules up to full crontab files.+++To do anything, you'll need to install cabal-dev with cabal.++To build, run:++ make++To run tests, run:++ make test++If you have inotify-tools, run this to run tests continuously.++ make autotest++To generate docs:++ make docs++#### Scheduler+Cron offers a scheduling monad which can be found in `System.Cron.Schedule`. This monad transform allows you to declare a set of jobs (of the type `IO ()`) that will be executed at intervals defined by cron strings.++```haskell+main :: IO ()+main = do+ ...+ tids <- execSchedule $ do+ addJob job1 "* * * * *"+ addJob job2 "0 * * * *"+ print tids+ ...++job1 :: IO ()+job1 = putStrLn "Job 1"++job2 :: IO ()+job2 = putStrLn "Job 2"+```++## Contributors++* [Simon Hengel](https://github.com/sol)+* [Alberto Valverde](https://github.com/albertov)+* [Andrew Rademacher](https://github.com/AndrewRademacher)
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ changelog view
@@ -0,0 +1,12 @@+# 0.2.5+* GHC 7.10 support+# 0.2.4+* Bugfixes for new task runner feature+# 0.2.3+* Add new in-process task runner feature. Credit to @AndrewRademacher+# 0.2.2+* Fix edge case when day of month and day of week are both specified. Credit to @joelwilliamson+# 0.2.1+* Fix day of week bug. Credit to @meteogrid+# 0.1.2+* Relax dependency on text to allow 1.0
+ cron-compat.cabal view
@@ -0,0 +1,76 @@+Name: cron-compat+Version: 0.2.6+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+ are used to.++ 'System.Cron' is where all the interesting datatypes live. You will also find+ 'scheduleMatches', which you can use to compare a time against a+ 'CronSchedule' to see if an action needs to be performed. System.Cron.Parser+ is where you will find the parsers `cronSchedule`, `crontabEntry` and+ `cronTab`. To parse individual schedules up to full crontab files.++Synopsis: Cron datatypes and Attoparsec parser+Category: Text, Parsing, System+License: MIT+License-file: LICENSE+Author: Michael Xavier <michael@michaelxavier.net>+Copyright: Copyright: (c) 2012-2014 Michael Xavier+Maintainer: Michael Xavier <michael@michaelxavier.net>+Build-Type: Simple+Stability: experimental+Tested-With: GHC == 7.4.1+ , GHC == 7.6.3+ , GHC == 7.8.3+ , GHC == 7.10.1+Cabal-Version: >= 1.8+Extra-Source-Files:+ 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++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.1 && <= 2.2,+ mtl-compat >= 0.2.1 && <= 0.2.2,+ transformers-compat >= 0.3.0.0+ ++test-suite spec+ Type: exitcode-stdio-1.0+ Main-Is: Spec.hs+ Hs-Source-Dirs: test+ Other-Modules: SpecHelper+ System.Cron.ParserSpec+ System.Cron.ScheduleSpec+ System.CronSpec+ Build-Depends: base >= 4 && < 5,+ cron,+ hspec >= 1.3,+ QuickCheck,+ derive,+ hspec-expectations,+ attoparsec >= 0.10,+ text >= 0.11 && < 2,+ time >= 1.4,+ transformers >= 0.4+ Ghc-Options: -threaded -rtsopts++source-repository head+ Type: git+ Location: https://github.com/michaelxavier/cron
+ src/System/Cron.hs view
@@ -0,0 +1,246 @@+--------------------------------------------------------------------+-- |+-- 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+++-- | 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 = [ x | x <- [start..finish], x `mod` step == 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
+ src/System/Cron/Parser.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------+-- |+-- Module : System.Cron.Parser+-- Description : Attoparsec parser for cron formatted intervals+-- Copyright : (c) Michael Xavier 2012+-- License : MIT+--+-- Maintainer: Michael Xavier <michael@michaelxavier.net>+-- Portability: portable+--+-- 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"+-- +--------------------------------------------------------------------+module System.Cron.Parser (cronSchedule,+ cronScheduleLoose,+ crontab,+ crontabEntry) where++import System.Cron++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure, (*>), (<$>), (<*), (<*>), (<|>))+#else+import Control.Applicative ((<$>), (<|>))+#endif+import Data.Char (isSpace)+import Data.Attoparsec.Text (Parser)+import qualified Data.Attoparsec.Text as A+import Data.Text (Text)++-- | 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+-- parser will fail if there is extraneous input. This is to prevent things+-- like extra fields. If you want a more lax parser, use 'cronScheduleLoose',+-- which is fine with extra input.+cronSchedule :: Parser CronSchedule+cronSchedule = cronScheduleLoose <* A.endOfInput++-- | Same as 'cronSchedule' but does not fail on extraneous input.+cronScheduleLoose :: Parser CronSchedule+cronScheduleLoose = yearlyP <|>+ monthlyP <|>+ weeklyP <|>+ dailyP <|>+ hourlyP <|>+ classicP++-- | Parses a full crontab file, omitting comments and including environment+-- variable sets (e.g FOO=BAR).+crontab :: Parser Crontab+crontab = Crontab <$> A.sepBy lineP (A.char '\n')+ 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+crontabEntry = A.skipSpace *> parser+ where parser = envVariableP <|>+ commandEntryP+ envVariableP = do var <- A.takeWhile1 (A.notInClass " =")+ A.skipSpace+ _ <- A.char '='+ A.skipSpace+ val <- A.takeWhile1 $ not . isSpace+ A.skipWhile (\c -> c == ' ' || c == '\t')+ return $ EnvVariable var val+ commandEntryP = CommandEntry <$> cronScheduleLoose+ <*> (A.skipSpace *> takeToEOL)++---- 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)+ <*> (dayOfMonthP <* space)+ <*> (monthP <* space)+ <*> dayOfWeekP+ where space = A.char ' '++cronFieldP :: Parser CronField+cronFieldP = steppedP <|>+ rangeP <|>+ listP <|>+ 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++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++hoursP :: Parser HourSpec+hoursP = Hours <$> cronFieldP++dayOfMonthP :: Parser DayOfMonthSpec+dayOfMonthP = DaysOfMonth <$> cronFieldP++monthP :: Parser MonthSpec+monthP = Months <$> cronFieldP++dayOfWeekP :: Parser DayOfWeekSpec+dayOfWeekP = DaysOfWeek <$> cronFieldP++parseInt :: Parser Int+parseInt = A.decimal++reduceList :: [CronField] -> CronField+reduceList [] = ListField [] -- this should not happen+reduceList [x] = x+reduceList xs = ListField xs
+ src/System/Cron/Schedule.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------+-- |+-- Module : System.Cron.Schedule+-- Description : Monad stack for scheduling jobs to be executed by cron rules.+-- Copyright : (c) Andrew Rademacher 2014+-- License : MIT+--+-- Maintainer: Andrew Rademacher <andrewrademacher@gmail.com>+-- Portability: portable+--+-- > main :: IO ()+-- > main = do+-- > ...+-- > tids <- execSchedule $ do+-- > addJob job1 "* * * * *"+-- > addJob job2 "0 * * * *"+-- > print tids+-- > ...+-- >+-- > job1 :: IO ()+-- > job1 = putStrLn "Job 1"+-- >+-- > job2 :: IO ()+-- > job2 = putStrLn "Job 2"+--+--------------------------------------------------------------------++module System.Cron.Schedule+ ( Job (..)+ , ScheduleError (..)+ , Schedule+ , ScheduleT (..)++ , MonadSchedule (..)++ , runSchedule+ , runScheduleT++ , execSchedule+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Concurrent+import Control.Monad.Except+import Control.Monad.Trans.Except+import Control.Monad.Error.Class+import Control.Monad.Identity+import Control.Monad.State+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++readTime' :: TimeLocale -> String -> String -> UTCTime+#if MIN_VERSION_time(1,5,0)+readTime' = parseTimeOrError True+#else+readTime' = readTime+#endif++{- Scheduleing 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 ()++instance (Monad m) => MonadSchedule (ScheduleT m) where+ addJob a t = do s :: Jobs <- get+ case parseOnly cronSchedule (pack t) of+ Left e -> throwError $ ParseError e+ Right t' -> put $ Job t' a : s++{- Monitoring Engine -}++execSchedule :: Schedule () -> IO [ThreadId]+execSchedule s = let res = runSchedule s+ in case res of+ Left e -> print e >> return []+ Right (_, jobs) -> mapM forkJob jobs++forkJob :: Job -> IO ThreadId+forkJob (Job s a) = forkIO $ forever $ do+ (timeAt, delay) <- findNextMinuteDelay+ threadDelay delay+ when (scheduleMatches s timeAt) a++findNextMinuteDelay :: IO (UTCTime, Int)+findNextMinuteDelay = do+ now <- getCurrentTime+ let f = formatTime defaultTimeLocale fmtFront now+ m = (read (formatTime defaultTimeLocale fmtMinutes now) :: Int) + 1+ r = f ++ ":" ++ if length (show m) == 1 then "0" ++ show m else show m+ next = readTime' defaultTimeLocale fmtRead r :: UTCTime+ diff = diffUTCTime next now+ delay = round (realToFrac (diff * 1000000) :: Double) :: Int+ return (next, delay)+ where fmtFront = "%F %H"+ fmtMinutes = "%M"+ fmtRead = "%F %H:%M"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}
+ test/SpecHelper.hs view
@@ -0,0 +1,29 @@+{-# 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)
+ test/System/Cron/ParserSpec.hs view
@@ -0,0 +1,179 @@+{-# 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)
+ test/System/Cron/ScheduleSpec.hs view
@@ -0,0 +1,45 @@+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
+ test/System/CronSpec.hs view
@@ -0,0 +1,224 @@+{-# 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