cron 0.5.0 → 0.7.2
raw patch · 16 files changed
Files
- README.md +2/−1
- changelog +12/−0
- cron.cabal +10/−10
- src/System/Cron/Internal/Check.hs +6/−4
- src/System/Cron/Internal/Describe/Options.hs +3/−3
- src/System/Cron/Internal/Schedule.hs +18/−0
- src/System/Cron/Parser.hs +96/−43
- src/System/Cron/Schedule.hs +8/−26
- src/System/Cron/Types.hs +17/−16
- test/Main.hs +2/−0
- test/SpecHelper.hs +89/−91
- test/System/Test/Cron.hs +96/−78
- test/System/Test/Cron/Describe.hs +1/−1
- test/System/Test/Cron/Internal/Schedule.hs +50/−0
- test/System/Test/Cron/Parser.hs +5/−2
- test/System/Test/Cron/Schedule.hs +7/−5
README.md view
@@ -10,7 +10,7 @@ `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. System.Cron.Descrive is where+individual schedules up to full crontab files. System.Cron.Describe is where you will find the `describe` function for creating human-readable strings from cron schedules, as well as any options to control how the description is created. @@ -71,3 +71,4 @@ * [Andrew Rademacher](https://github.com/AndrewRademacher) * [Peter Simons](https://github.com/peti) * [Joseph Canero](https://github.com/caneroj1)+* [Ahti Katiska](https://github.com/HariGyogu)
changelog view
@@ -1,3 +1,15 @@+# 0.7.2+* Replace data-default-class with data-default, Michael Xavier (@MichaelXavier)+# 0.7.1+* expose fork job, Jappie Klooster (@jappeace)+# 0.7.0+* Fix time parsing error (#41), Julien Debon (@Sir4ur0n)+# 0.6.2+* Updates to allow GHC 8.8+# 0.6.1+* Add support for day and month literals, Ahti Katiska (@HariGyogu).+# 0.6.0+* Use Text instead of String in Cron.Schedule # 0.5.0 * Add System.Cron.Describe which describes cron schedules in words (English only for now). Big thanks to Joe Canero for this feature! # 0.4.2
cron.cabal view
@@ -1,5 +1,5 @@ Name: cron-Version: 0.5.0+Version: 0.7.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@@ -20,10 +20,9 @@ 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+Tested-With: GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.1 Cabal-Version: >= 1.10 Extra-Source-Files: README.md@@ -50,6 +49,7 @@ , System.Cron.Internal.Describe.Types , System.Cron.Internal.Describe.Utils , System.Cron.Internal.Check+ , System.Cron.Internal.Schedule , System.Cron.Describe , System.Cron.Parser , System.Cron.Schedule@@ -58,13 +58,13 @@ default-language: Haskell2010 build-depends: base >= 4 && < 5 , attoparsec >= 0.10- , text >= 0.11 && < 2+ , text >= 0.11 && < 3 , time >= 1.4 , old-locale >= 1.0 , mtl >= 2.0.1 , mtl-compat >= 0.2.1 , semigroups- , data-default-class >= 0.0.1+ , data-default if flag(lib-Werror) ghc-options: -Werror @@ -81,18 +81,18 @@ , System.Test.Cron.Describe , System.Test.Cron.Parser , System.Test.Cron.Schedule+ , System.Test.Cron.Internal.Schedule Build-Depends: base , cron , tasty , tasty-hunit- , tasty-quickcheck+ , tasty-hedgehog+ , hedgehog , attoparsec , text , time , transformers-compat , semigroups- , quickcheck-instances- , generics-sop >= 0.2 if flag(lib-Werror) ghc-options: -Werror
src/System/Cron/Internal/Check.hs view
@@ -9,11 +9,13 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Semigroup (sconcat)-import Data.Time-import Data.Time.Calendar.WeekDate+import Data.Time (Day, DiffTime, UTCTime (..),+ addUTCTime, fromGregorianValid,+ toGregorian)+import Data.Time.Calendar.WeekDate (toWeekDate) import qualified Data.Traversable as FT --------------------------------------------------------------------------------import System.Cron.Types+import System.Cron.Types as CT ------------------------------------------------------------------------------- @@ -41,7 +43,7 @@ domStarSpec <- mkDayOfMonthSpec (Field Star) dowStarSpec <- mkDayOfWeekSpec (Field Star) let domStarResult = nextMatch cs { dayOfMonth = domStarSpec } now- let dowStarResult = nextMatch cs { dayOfWeek = dowStarSpec} now+ let dowStarResult = nextMatch cs { CT.dayOfWeek = dowStarSpec} now listToMaybe (sort (catMaybes [domStarResult, dowStarResult])) | otherwise = do expanded@Expanded {..} <- expand cs
src/System/Cron/Internal/Describe/Options.hs view
@@ -12,8 +12,8 @@ module System.Cron.Internal.Describe.Options where --------------------------------------------------------------------------------import Data.Default.Class-import Data.Semigroup+import Data.Default+import Data.Semigroup as Semigroup ------------------------------------------------------------------------------- import System.Cron.Internal.Describe.Types -------------------------------------------------------------------------------@@ -77,7 +77,7 @@ instance Default Options where def = Opts {timeFormat = Hour12, verbosity = NotVerbose} -instance Semigroup OptionBuilder where+instance Semigroup.Semigroup OptionBuilder where (Builder f) <> (Builder a) = Builder (a . f) instance Monoid OptionBuilder where
+ src/System/Cron/Internal/Schedule.hs view
@@ -0,0 +1,18 @@+module System.Cron.Internal.Schedule (findNextMinuteDelay') where++import Data.Time++findNextMinuteDelay' :: UTCTime -> (UTCTime, Int)+findNextMinuteDelay' now = (next, delay)+ where+ oneMinuteLater = addUTCTime oneMinute now+ plainMinute = truncateToPlainMinute $ utctDayTime oneMinuteLater+ next = oneMinuteLater { utctDayTime = plainMinute }+ diff = diffUTCTime next now+ delay = round (realToFrac (diff * 1000000) :: Double) :: Int++oneMinute :: NominalDiffTime+oneMinute = 60++truncateToPlainMinute :: DiffTime -> DiffTime+truncateToPlainMinute = fromIntegral . (* 60) . (`quot` 60) . (truncate :: DiffTime -> Integer)
src/System/Cron/Parser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------- -- |@@ -32,12 +33,14 @@ ) where --------------------------------------------------------------------------------import Control.Applicative as Ap-import Data.Attoparsec.Text (Parser)-import qualified Data.Attoparsec.Text as A-import Data.Char (isSpace)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Text (Text)+import Control.Applicative as Ap+import Control.Monad.Fail as F+import Data.Attoparsec.Combinator (choice)+import Data.Attoparsec.Text (Parser)+import qualified Data.Attoparsec.Text as A+import Data.Char (isSpace)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text, toLower) ------------------------------------------------------------------------------- import System.Cron.Types -------------------------------------------------------------------------------@@ -97,7 +100,7 @@ parseCronSchedule :: Text -> Either String CronSchedule-parseCronSchedule = A.parseOnly cronSchedule+parseCronSchedule = A.parseOnly cronSchedule . toLower -------------------------------------------------------------------------------@@ -135,21 +138,21 @@ --------------------------------------------------------------------------------cronFieldP :: Parser CronField-cronFieldP = stepP <|>- listP <|>- fieldP-+cronFieldP :: StringSupport -> Parser CronField+cronFieldP stringSupport =+ stepP <|>+ listP <|>+ fieldP where- fieldP = Field <$> baseFieldP- listP = ListField <$> neListP baseFieldP- stepP = StepField' <$> stepFieldP+ fieldP = Field <$> baseFieldP stringSupport+ listP = ListField <$> neListP (baseFieldP stringSupport)+ stepP = StepField' <$> stepFieldP stringSupport --------------------------------------------------------------------------------stepFieldP :: Parser StepField-stepFieldP = do- f <- baseFieldP+stepFieldP :: StringSupport -> Parser StepField+stepFieldP ss = do+ f <- baseFieldP ss _ <- A.char '/' mParse (mkStepField f) "invalid stepping" =<< parseInt @@ -158,35 +161,33 @@ neListP :: Parser a -> Parser (NonEmpty a) neListP p = coerceNE =<< A.sepBy1 p (A.char ',') where- coerceNE [] = fail "expected non-empty list"- coerceNE [_] = fail "invalid singleton list"+ coerceNE [] = F.fail "expected non-empty list"+ coerceNE [_] = F.fail "invalid singleton list" coerceNE (x:xs) = return $ x :| xs --------------------------------------------------------------------------------baseFieldP :: Parser BaseField-baseFieldP = rangeP <|>- starP <|>- specificP+baseFieldP :: StringSupport -> Parser BaseField+baseFieldP ss = rangeP <|>+ starP <|>+ specificP where starP = A.char '*' *> Ap.pure Star- rangeP = RangeField' <$> rangeFieldP- specificP = SpecificField' <$> specificFieldP+ rangeP = RangeField' <$> rangeFieldP ss+ specificP = SpecificField' <$> specificFieldP ss --------------------------------------------------------------------------------specificFieldP :: Parser SpecificField-specificFieldP =- mParse mkSpecificField "specific field value out of range" =<< parseInt-+specificFieldP :: StringSupport -> Parser SpecificField+specificFieldP ss =+ mParse mkSpecificField "specific field value out of range"+ =<< supportParser ss --------------------------------------------------------------------------------rangeFieldP :: Parser RangeField-rangeFieldP = do- begin <- parseInt--+rangeFieldP :: StringSupport -> Parser RangeField+rangeFieldP ss = do+ begin <- supportParser ss _ <- A.char '-'- end <- parseInt+ end <- supportParser ss mParse (mkRangeField begin) "start of range must be less than or equal to end" end @@ -217,34 +218,86 @@ ------------------------------------------------------------------------------- minutesP :: Parser MinuteSpec-minutesP = mParse mkMinuteSpec "minutes out of range" =<< cronFieldP+minutesP = mParse mkMinuteSpec "minutes out of range" =<< cronFieldP NoString ------------------------------------------------------------------------------- hoursP :: Parser HourSpec-hoursP = mParse mkHourSpec "hours out of range" =<< cronFieldP+hoursP = mParse mkHourSpec "hours out of range" =<< cronFieldP NoString ------------------------------------------------------------------------------- dayOfMonthP :: Parser DayOfMonthSpec-dayOfMonthP = mParse mkDayOfMonthSpec "day of month out of range" =<< cronFieldP+dayOfMonthP = mParse mkDayOfMonthSpec "day of month out of range" =<< cronFieldP NoString ------------------------------------------------------------------------------- monthP :: Parser MonthSpec-monthP = mParse mkMonthSpec "month out of range" =<< cronFieldP+monthP = mParse mkMonthSpec "month out of range" =<< cronFieldP MonthString ------------------------------------------------------------------------------- dayOfWeekP :: Parser DayOfWeekSpec-dayOfWeekP = mParse mkDayOfWeekSpec "day of week out of range" =<< cronFieldP+dayOfWeekP = mParse mkDayOfWeekSpec "day of week out of range" =<< cronFieldP DayString ------------------------------------------------------------------------------- parseInt :: Parser Int parseInt = A.decimal +-------------------------------------------------------------------------------+data StringSupport+ = MonthString+ | DayString+ | NoString+ deriving Eq --------------------------------------------------------------------------------mParse :: (Monad m) => (a -> Maybe b) -> String -> a -> m b-mParse f msg = maybe (fail msg) return . f+supportParser :: StringSupport -> Parser Int+supportParser = \case+ MonthString -> choice [parseMonth, parseInt]+ DayString -> choice [parseDay, parseInt]+ NoString -> parseInt++-------------------------------------------------------------------------------++toI :: Int -> Text -> Parser Int+toI int str = const int <$> A.string str++-------------------------------------------------------------------------------+parseDay :: Parser Int+parseDay =+ choice $+ zipWith toI+ [1 .. 7]+ [ "mon"+ , "tue"+ , "wed"+ , "thu"+ , "fri"+ , "sat"+ , "sun"+ ]++-------------------------------------------------------------------------------+parseMonth :: Parser Int+parseMonth =+ choice $+ zipWith toI+ [1 .. 12]+ [ "jan"+ , "feb"+ , "mar"+ , "apr"+ , "may"+ , "jun"+ , "jul"+ , "aug"+ , "sep"+ , "oct"+ , "nov"+ , "dec"]++-------------------------------------------------------------------------------+mParse :: (Monad m, MonadFail m) => (a -> Maybe b) -> String -> a -> m b+mParse f msg = maybe (F.fail msg) return . f
src/System/Cron/Schedule.hs view
@@ -31,6 +31,7 @@ module System.Cron.Schedule ( Job (..)+ , forkJob , ScheduleError (..) , Schedule , ScheduleT (..)@@ -49,32 +50,24 @@ import Control.Applicative #endif import Control.Concurrent+import Control.Monad (forever, when, void) import Control.Monad.Except import Control.Monad.Identity import Control.Monad.State import Data.Attoparsec.Text (parseOnly)-import Data.Text (pack)+import Data.Text (Text) import Data.Time #if !MIN_VERSION_time(1,5,0) import System.Locale #endif ------------------------------------------------------------------------------- import System.Cron.Internal.Check+import System.Cron.Internal.Schedule import System.Cron.Parser import System.Cron.Types ------------------------------------------------------------------------------- --readTime' :: TimeLocale -> String -> String -> UTCTime-#if MIN_VERSION_time(1,5,0)-readTime' = parseTimeOrError True-#else-readTime' = readTime-#endif---------------------------------------------------------------------------------- -- | Scheduling Monad data Job = Job CronSchedule (IO ()) @@ -87,7 +80,7 @@ --------------------------------------------------------------------------------data ScheduleError = ParseError String+newtype ScheduleError = ParseError String deriving (Show) @@ -115,11 +108,11 @@ ------------------------------------------------------------------------------- class MonadSchedule m where- addJob :: IO () -> String -> m ()+ addJob :: IO () -> Text -> m () instance (Monad m) => MonadSchedule (ScheduleT m) where addJob a t = do s :: Jobs <- get- case parseOnly cronSchedule (pack t) of+ case parseOnly cronSchedule t of Left e -> throwError $ ParseError e Right t' -> put $ Job t' a : s @@ -156,15 +149,4 @@ ------------------------------------------------------------------------------- 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"+findNextMinuteDelay = findNextMinuteDelay' <$> getCurrentTime
src/System/Cron/Types.hs view
@@ -55,11 +55,12 @@ ------------------------------------------------------------------------------- import Control.Applicative as A+import Data.Data (Data) import qualified Data.Foldable as FT import Data.Ix import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import Data.Monoid+import Data.Monoid as Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable)@@ -132,11 +133,11 @@ , 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, Generic, Typeable)+ } deriving (Eq, Generic, Data, Typeable) instance Show CronSchedule where- show cs = "CronSchedule " <> T.unpack (showT cs)+ show cs = "CronSchedule " Monoid.<> T.unpack (showT cs) instance ShowT CronSchedule where@@ -155,7 +156,7 @@ -- | Crontab file, omitting comments. newtype Crontab = Crontab { crontabEntries :: [CrontabEntry]- } deriving (Eq, Generic, Typeable)+ } deriving (Eq, Generic, Data, Typeable) instance ShowT Crontab where@@ -173,7 +174,7 @@ ------------------------------------------------------------------------------- newtype CronCommand = CronCommand { cronCommand :: Text- } deriving (Show, Eq, Ord, ShowT, Generic, Typeable)+ } deriving (Show, Eq, Ord, ShowT, Generic, Data, Typeable) -------------------------------------------------------------------------------@@ -181,7 +182,7 @@ -- command after it or setting an environment variable (e.g. FOO=BAR) data CrontabEntry = CommandEntry CronSchedule CronCommand | EnvVariable Text Text- deriving (Eq, Generic, Typeable)+ deriving (Eq, Generic, Data, Typeable) instance ShowT CrontabEntry where@@ -196,7 +197,7 @@ -- | Minutes field of a cron expression newtype MinuteSpec = Minutes { minuteSpec :: CronField- } deriving (Eq, ShowT, Generic, Typeable)+ } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show MinuteSpec where@@ -214,7 +215,7 @@ -- | Hours field of a cron expression newtype HourSpec = Hours { hourSpec :: CronField- } deriving (Eq, ShowT, Generic, Typeable)+ } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show HourSpec where@@ -231,7 +232,7 @@ -- | Day of month field of a cron expression newtype DayOfMonthSpec = DaysOfMonth { dayOfMonthSpec :: CronField- } deriving (Eq, ShowT, Generic, Typeable)+ } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show DayOfMonthSpec where@@ -248,7 +249,7 @@ -- | Month field of a cron expression newtype MonthSpec = Months { monthSpec :: CronField- } deriving (Eq, ShowT, Generic, Typeable)+ } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show MonthSpec where@@ -265,7 +266,7 @@ -- | Day of week field of a cron expression newtype DayOfWeekSpec = DaysOfWeek { dayOfWeekSpec :: CronField- } deriving (Eq, ShowT, Generic, Typeable)+ } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show DayOfWeekSpec where@@ -312,7 +313,7 @@ data BaseField = Star -- ^ Matches anything | SpecificField' SpecificField -- ^ Matches a specific value (e.g. 1) | RangeField' RangeField -- ^ Matches a range of values (e.g. 1-3)- deriving (Eq, Generic, Typeable)+ deriving (Eq, Generic, Data, Typeable) instance ShowT BaseField where@@ -328,7 +329,7 @@ ------------------------------------------------------------------------------- newtype SpecificField = SpecificField { specificField :: Int- } deriving (Eq, ShowT, Generic, Typeable)+ } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show SpecificField where@@ -345,7 +346,7 @@ data RangeField = RangeField { rfBegin :: Int , rfEnd :: Int- } deriving (Eq, Generic, Typeable)+ } deriving (Eq, Generic, Data, Typeable) instance ShowT RangeField where@@ -367,7 +368,7 @@ data CronField = Field BaseField | ListField (NonEmpty BaseField) -- ^ Matches a list of expressions. | StepField' StepField -- ^ Matches a stepped expression, e.g. (*/2).- deriving (Generic)+ deriving (Generic, Data, Typeable) instance Eq CronField where@@ -392,7 +393,7 @@ ------------------------------------------------------------------------------- data StepField = StepField { sfField :: BaseField , sfStepping :: Int- } deriving (Eq, Generic)+ } deriving (Eq, Generic, Data, Typeable) instance ShowT StepField where
test/Main.hs view
@@ -10,6 +10,7 @@ import qualified System.Test.Cron.Describe import qualified System.Test.Cron.Parser import qualified System.Test.Cron.Schedule+import qualified System.Test.Cron.Internal.Schedule ------------------------------------------------------------------------------- @@ -19,4 +20,5 @@ , System.Test.Cron.Describe.tests , System.Test.Cron.Parser.tests , System.Test.Cron.Schedule.tests+ , System.Test.Cron.Internal.Schedule.tests ]
test/SpecHelper.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TemplateHaskell #-}+ module SpecHelper ( module X , module SpecHelper@@ -9,116 +12,111 @@ --------------------------------------------------------------------------------import Control.Applicative as X-import Data.Attoparsec.Text as X (Parser, parseOnly)-import qualified Data.List.NonEmpty as NE-import Data.Maybe as X-import Data.Monoid as X-import Data.Proxy (Proxy (..))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar as X-import Data.Time.Clock as X-import Data.Time.LocalTime as X-import Debug.Trace as X-import qualified Generics.SOP as SOP-import qualified Generics.SOP.GGP as SOP-import GHC.Generics (Generic)-import Test.QuickCheck.Instances ()-import Test.Tasty as X-import Test.Tasty.HUnit as X-import Test.Tasty.QuickCheck as X+import Control.Applicative as X+import Data.Attoparsec.Text as X (Parser, parseOnly)+import qualified Data.List.NonEmpty as NE+import Data.Maybe as X+import Data.Monoid as X+import Data.Text (Text)+import Data.Time.Calendar as X (Day (..), fromGregorian,+ toGregorian)+import Data.Time.Clock as X (DiffTime, UTCTime (..), addUTCTime,+ diffUTCTime, picosecondsToDiffTime,+ secondsToDiffTime)+import qualified Data.Time.Clock.POSIX as POSIX+import Data.Time.LocalTime as X+import Debug.Trace as X+import GHC.Generics (Generic)+import qualified GHC.Generics as G+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty as X+import Test.Tasty.Hedgehog as X+import Test.Tasty.HUnit as X --------------------------------------------------------------------------------import System.Cron as X+import System.Cron as X ------------------------------------------------------------------------------- --- this workaround is in place until we successfully beat down the--- doors of castle QuickCheck and get generic deriving through. See--- <https://github.com/nick8325/quickcheck/pull/40>-sopArbitrary :: (Generic a, SOP.GTo a, SOP.All SOP.SListI (SOP.GCode a), SOP.All2 Arbitrary (SOP.GCode a)) => Gen a-sopArbitrary = fmap SOP.gto sopArbitrary'---sopArbitrary' :: (SOP.All SOP.SListI xss, SOP.All2 Arbitrary xss) => Gen (SOP.SOP SOP.I xss)-sopArbitrary' = oneof (map SOP.hsequence $ SOP.apInjs_POP $ SOP.hcpure p arbitrary)- where- p :: Proxy Arbitrary- p = Proxy---instance Arbitrary BaseField where- arbitrary = sopArbitrary- shrink = genericShrink---instance Arbitrary CronField where- arbitrary = oneof [ Field <$> arbitrary- , ListField . NE.fromList . getNonEmpty <$> arbitrary- , StepField' <$> arbitrary- ]---instance Arbitrary CronSchedule where- arbitrary = sopArbitrary- shrink = genericShrink---instance Arbitrary Crontab where- arbitrary = Crontab <$> resize 20 arbitrary---instance Arbitrary CronCommand where- arbitrary = CronCommand <$> alphaGen---instance Arbitrary CrontabEntry where- arbitrary = oneof [ CommandEntry <$> arbitrary <*> arbitrary- , EnvVariable <$> alphaGen <*> alphaGen- ]+-- | A necessary evil for generators that can generically make sure+-- all constructors of your sum type are covered. The tradeoff is that+-- you have no control over the range at the per-test level, so use+-- this sparingly where full coverage is more valuable than+-- fine-tuning generators.+class HasGen a where+ gen :: Gen a+ default gen :: (Generic a, GHasGen (G.Rep a)) => Gen a+ gen = Gen.choice (fmap G.to <$> ggen) -alphaGen :: Gen Text-alphaGen = T.pack <$> listOf1 gen- where- gen = elements (['a'..'z'] <> ['A'..'Z'])--instance Arbitrary MinuteSpec where- arbitrary = arbitraryMaybe mkMinuteSpec-+class GHasGen f where+ ggen :: [Gen (f a)] -instance Arbitrary HourSpec where- arbitrary = arbitraryMaybe mkHourSpec+instance GHasGen G.U1 where+ ggen = [pure G.U1] +instance (HasGen a) => GHasGen (G.K1 i a) where+ ggen = [G.K1 <$> gen] -instance Arbitrary DayOfMonthSpec where- arbitrary = arbitraryMaybe mkDayOfMonthSpec+instance (GHasGen a, GHasGen b) => GHasGen (a G.:*: b) where+ ggen = [ (G.:*:) <$> f <*> g | f <- ggen, g <- ggen] +instance (GHasGen a, GHasGen b) => GHasGen (a G.:+: b) where+ ggen = (fmap G.L1 <$> ggen) <> (fmap G.R1 <$> ggen) -instance Arbitrary MonthSpec where- arbitrary = arbitraryMaybe mkMonthSpec+-- we don't care about metadata, lift over it+instance (GHasGen c) => GHasGen (G.M1 _a _b c) where+ ggen = fmap G.M1 <$> ggen -instance Arbitrary DayOfWeekSpec where- arbitrary = arbitraryMaybe mkDayOfWeekSpec-+instance HasGen BaseField+instance HasGen SpecificField+instance HasGen RangeField+instance HasGen Int where+ gen = Gen.int Range.linearBounded+instance HasGen Text where+ gen = genAlpha+instance HasGen CronField+instance HasGen a => HasGen (NE.NonEmpty a) where+ gen = Gen.nonEmpty (Range.linear 1 50) gen+instance HasGen a => HasGen [a] where+ gen = Gen.list (Range.linear 0 50) gen+instance HasGen StepField where+ gen = Gen.just (mkStepField <$> gen <*> gen)+instance HasGen CronSchedule+instance HasGen Crontab+instance HasGen CronCommand where+ gen = CronCommand <$> genAlpha+instance HasGen CrontabEntry+instance HasGen MinuteSpec where+ gen = Gen.just (mkMinuteSpec <$> gen)+instance HasGen HourSpec where+ gen = Gen.just (mkHourSpec <$> gen)+instance HasGen DayOfMonthSpec where+ gen = Gen.just (mkDayOfMonthSpec <$> gen)+instance HasGen DayOfWeekSpec where+ gen = Gen.just (mkDayOfWeekSpec <$> gen)+instance HasGen MonthSpec where+ gen = Gen.just (mkMonthSpec <$> gen)+instance HasGen UTCTime where+ gen = genUTCTime -instance Arbitrary SpecificField where- arbitrary = arbitraryMaybe mkSpecificField+genAlpha :: Gen Text+genAlpha = Gen.text (Range.linear 1 50) Gen.alpha -instance Arbitrary RangeField where- arbitrary = arbitraryMaybe (uncurry mkRangeField)+genUTCTime :: Gen UTCTime+genUTCTime = genUTCTime' (Range.linear 0 maxBound) -instance Arbitrary StepField where- arbitrary = arbitraryMaybe (uncurry mkStepField)+-- | genUTCTime with a range of posix seconds+genUTCTime' :: Range.Range Int -> Gen UTCTime+genUTCTime' = fmap POSIX.posixSecondsToUTCTime . genPOSIXTime -arbitraryMaybe :: Arbitrary a => (a -> Maybe b) -> Gen b-arbitraryMaybe f = do- a <- arbitrary `suchThat` (isJust . f)- return (fromJust (f a))+genPOSIXTime :: Range.Range Int -> Gen POSIX.POSIXTime+genPOSIXTime rnge = fromInteger . toInteger <$> Gen.int rnge mkMinuteSpec' :: CronField -> MinuteSpec
test/System/Test/Cron.hs view
@@ -2,9 +2,13 @@ module System.Test.Cron (tests) where --------------------------------------------------------------------------------import Data.List (find)-import Data.List.NonEmpty (NonEmpty (..))+import Control.Monad+import Data.List (find)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Time.Clock.POSIX+import Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range ------------------------------------------------------------------------------- import SpecHelper -------------------------------------------------------------------------------@@ -98,8 +102,8 @@ (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 oddMinute = either error id $ parseOnly cronSchedule "1-59/2 * * * *"+ let evenMinute = either error id $ 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@@ -107,51 +111,59 @@ scheduleMatches evenMinute t1 @?= False scheduleMatches evenMinute t2 @?= True - , testProperty "star matches everything" $ \t ->- scheduleMatches stars t+ , testProperty "star matches everything" $ property $ do+ t <- forAll gen+ HH.assert (scheduleMatches stars t) - , testProperty "exact time matches" $ \t ->- let (_, m, d, h, mn) = timeComponents t- sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))))- (mkHourSpec' (Field (SpecificField' (mkSpecificField' h))))- (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d))))- (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m))))- (mkDayOfWeekSpec' (Field Star))- in scheduleMatches sched t+ , testProperty "exact time matches" $ property $ do+ t <- forAll gen+ let (_, m, d, h, mn) = timeComponents t+ sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))))+ (mkHourSpec' (Field (SpecificField' (mkSpecificField' h))))+ (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d))))+ (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m))))+ (mkDayOfWeekSpec' (Field Star))+ HH.assert (scheduleMatches sched t) - , testProperty "any time with the same minute as n * * * * matches" $ arbitraryTimeFields $ \y m d h mn ->- let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))) }- t = day' y m d h mn- in scheduleMatches sched t+ , testProperty "any time with the same minute as n * * * * matches" $ property $ do+ (y, m, d, h, mn) <- forAll genTimeFields+ let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))) }+ t = day' y m d h mn+ HH.assert (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 = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' (stepMax 59 mn)))) }- t = day' y m d h mn- in not $ scheduleMatches sched t+ , testProperty "any time with the diff minute as n * * * * does not match" $ property $ do+ (y, m, d, h, mn) <- forAll genTimeFields+ let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' (stepMax 59 mn)))) }+ t = day' y m d h mn+ HH.assert (not (scheduleMatches sched t)) - , testProperty "any time with the same hour as * n * * * matches" $ arbitraryTimeFields $ \y m d h mn ->- let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' h))) }- t = day' y m d h mn- in scheduleMatches sched t+ , testProperty "any time with the same hour as * n * * * matches" $ property $ do+ (y, m, d, h, mn) <- forAll genTimeFields+ let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' h))) }+ t = day' y m d h mn+ HH.assert (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 = mkHourSpec' (Field (SpecificField' (mkSpecificField' (stepMax 23 h)))) }- t = day' y m d h mn- in not $ scheduleMatches sched t+ , testProperty "any time with the diff hour as * n * * * does not match" $ property $ do+ (y, m, d, h, mn) <- forAll genTimeFields+ let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' (stepMax 23 h)))) }+ t = day' y m d h mn+ HH.assert (not (scheduleMatches sched t)) - , testProperty "any time with the same day as * * n * * matches" $ \t ->- let (_, m, d, h, mn) = timeComponents t- sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))))- (mkHourSpec' (Field (SpecificField' (mkSpecificField' h))))- (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d))))- (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m))))- (mkDayOfWeekSpec' (Field Star))- in scheduleMatches sched t+ , testProperty "any time with the same day as * * n * * matches" $ property $ do+ t <- forAll gen+ let (_, m, d, h, mn) = timeComponents t+ sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))))+ (mkHourSpec' (Field (SpecificField' (mkSpecificField' h))))+ (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d))))+ (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m))))+ (mkDayOfWeekSpec' (Field Star))+ HH.assert (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 = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' (stepMax 31 d)))) }- t = day' y m d h mn- in not $ scheduleMatches sched t+ , testProperty "any time with the diff day as * * n * * does not match" $ property $ do+ (y, m, d, h, mn) <- forAll genTimeFields+ let sched = stars { dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' (stepMax 31 d)))) }+ t = day' y m d h mn+ HH.assert (not (scheduleMatches sched t)) ] @@ -159,29 +171,18 @@ day' y m d h mn = UTCTime (fromGregorian y m d) (diffTime h mn) diffTime h mn = timeOfDayToTime $ TimeOfDay h mn 1 -arbitraryTimeFields- :: (Num r- , Num r1- , Num r2- , Num r3- , Ord r- , Ord r1- , Ord r2- , Ord r3- )- => (a -> r -> r1 -> r2 -> r3 -> t)- -> Positive a- -> Positive r- -> Positive r1- -> Positive r2- -> Positive r3- -> t-arbitraryTimeFields f y m d h mn = f (getPositive y)- (min 12 $ getPositive m)- (min 28 $ getPositive d)- (min 23 $ getPositive h)- (min 59 $ getPositive mn) +genTimeFields+ :: Gen (Integer, Int, Int, Int, Int)+genTimeFields = do+ y <- Gen.integral (Range.linear 0 9999)+ m <- Gen.int (Range.linear 1 12)+ d <- Gen.int (Range.linear 1 28)+ h <- Gen.int (Range.linear 1 23)+ mn <- Gen.int (Range.linear 1 59)+ pure (y, m, d, h, mn)++ hoursMins :: DiffTime -> (Int, Int) hoursMins uTime = (hr, mn) where@@ -255,32 +256,49 @@ describeNextMatch :: TestTree describeNextMatch = testGroup "nextMatch"- [ testProperty "is always in the future (at least 1 minute advanced)" $ \cs t ->+ [ testProperty "is always in the future (at least 1 minute advanced)" $ property $ do+ cs <- forAll gen+ t <- forAll gen let tSecs = floor (utcTimeToPOSIXSeconds t) :: Integer minT2 = posixSecondsToUTCTime (fromInteger ((tSecs `div` 60) + 1) * 60)- in case nextMatch cs t of- Just t2 -> t2 >= minT2- Nothing -> True- , testProperty "always produces a time that will match the schedule" $ \cs t -> case nextMatch cs t of- Just t2 -> counterexample (show t2 <> " does not match " <> show cs) (scheduleMatches cs t2)- Nothing -> property True+ Just t2 -> HH.assert (t2 >= minT2)+ Nothing -> success+ , testProperty "always produces a time that will match the schedule" $ property $ do+ cs <- forAll gen+ t <- forAll gen+ case nextMatch cs t of+ Just t2 -> do+ unless (scheduleMatches cs t2) $ do+ annotate (show t2 <> " does not match " <> show cs)+ failure+ Nothing -> success -- , testCase "special case" $ do -- let Right cs = parseOnly cronSchedule "* * * * *" -- t = mkTime 1858 11 20 0 0 1 -- nextMatch cs t @?= Just (mkTime 1858 11 20 0 1 0) -- this test has a really variable workload but is usually quite slow because it has to walk minute by minute until it finds the test case, so we'll set an upper bound here- , localOption (QuickCheckTests 20) $ testProperty "returns the first minute in the future that matches" $ \cs t ->+ --TODO: resize 20?+ , testProperty "returns the first minute in the future that matches" $ property $ do+ cs <- forAll gen+ t <- forAll gen case nextMatch cs t of Just res -> let mactual = find (scheduleMatches cs) ((takeWhile (<= res) (nextMinutes t))) in case mactual of Just actual -> res `sameMinute` actual- Nothing -> counterexample ("Could not find a next minute match for " <> show t <> ", expected " <> show res) False- Nothing -> property True- , testProperty "a schedule that produces Just for one t will produce it for any t" $ \cs t1 t2 -> isJust (nextMatch cs t1) ==>- counterexample ("nextMatch produced Just for " <> show t1 <> " but not " <> show t2)- (isJust (nextMatch cs t2) == True)+ Nothing -> do+ annotate ("Could not find a next minute match for " <> show t <> ", expected " <> show res)+ failure+ Nothing -> success+ , testProperty "a schedule that produces Just for one t will produce it for any t" $ property $ do+ cs <- forAll gen+ t1 <- forAll (Gen.filter (isJust . nextMatch cs) gen)+ t2 <- forAll gen+ unless (isJust (nextMatch cs t2) == True) $ do+ annotate ("nextMatch produced Just for " <> show t1 <> " but not " <> show t2)+ failure+ , testCase "does not match impossible dates (restricted dow/dom bug)" $ do let t = posixSecondsToUTCTime 0 let cs = stars { month = mkMonthSpec' (Field (SpecificField' (mkSpecificField' 9)))@@ -291,7 +309,7 @@ ] -sameMinute :: UTCTime -> UTCTime -> Property+sameMinute :: (MonadTest m) => UTCTime -> UTCTime -> m () sameMinute t1 t2 = t1' === t2' where t1' = t1 { utctDayTime = roundToMinute (utctDayTime t1)}
test/System/Test/Cron/Describe.hs view
@@ -126,7 +126,7 @@ ] ] where- mkCronSchedule t = let (Right cs) = parseCronSchedule t in cs+ mkCronSchedule t = let cs = either error id $ parseCronSchedule t in cs describeNV = describe (twentyFourHourFormat <> notVerbose) . mkCronSchedule describeV = describe (twentyFourHourFormat <> verbose) . mkCronSchedule describe12 = describe verbose . mkCronSchedule
+ test/System/Test/Cron/Internal/Schedule.hs view
@@ -0,0 +1,50 @@+module System.Test.Cron.Internal.Schedule+ ( tests,+ )+where++-------------------------------------------------------------------------------+import Hedgehog+-------------------------------------------------------------------------------+import SpecHelper+import System.Cron.Internal.Schedule++-------------------------------------------------------------------------------++tests :: TestTree+tests =+ testGroup+ "System.Cron.Schedule"+ [ describeFindNextMinuteDelay'+ ]++describeFindNextMinuteDelay' :: TestTree+describeFindNextMinuteDelay' =+ testGroup+ "findNextMinuteDelay'"+ [ testCase "should find next minute of arbitrary time." $+ let now = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 29085749437046123} -- 2020-02-27 08:04:45.749437046 UTC+ nextMinute = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 29100000000000000} -- 2020-02-27 08:05:00.000000000 UTC+ in findNextMinuteDelay' now @?= (nextMinute, 14250563),+ testCase "should find next minute of 59 minutes." $+ let now = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 32357749437046123} -- 2020-02-27 08:59:17.749437046123 UTC+ nextMinute = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 32400000000000000} -- 2020-02-27 09:00:00.000000000 UTC+ in findNextMinuteDelay' now @?= (nextMinute, 42250563),+ testCase "should find next minute of 0 minute." $+ let now = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 32400123456789012} -- 2020-02-27 09:00:00.123456789012 UTC+ nextMinute = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 32460000000000000} -- 2020-02-27 09:01:00.000000000 UTC+ in findNextMinuteDelay' now @?= (nextMinute, 59876543),+ testCase "should find next minute before midnight." $+ let now = UTCTime {utctDay = ModifiedJulianDay 58906, utctDayTime = picosecondsToDiffTime 86387123456789012} -- 2020-02-27 23:59:47.123456789012 UTC+ nextMinute = UTCTime {utctDay = ModifiedJulianDay 58907, utctDayTime = picosecondsToDiffTime 0} -- 2020-02-28 00:00:00.000000000 UTC+ in findNextMinuteDelay' now @?= (nextMinute, 12876543),+ testProperty "invariance: next minute is after and no more than 60s later." $ property $ do+ now <- forAll gen+ let (nextMinute, delay) = findNextMinuteDelay' now+ ((nextMinute > now) && (delay <= 60000000)) === True,+ testProperty "invariance: next minute after next minute is *exactly* 60s." $ property $ do+ now <- forAll gen+ let (nextMinute1, _) = findNextMinuteDelay' now+ let (nextMinute2, delay) = findNextMinuteDelay' nextMinute1+ ((diffUTCTime nextMinute2 nextMinute1 == 60) && (delay == 60000000)) === True+ ]
test/System/Test/Cron/Parser.hs view
@@ -4,6 +4,7 @@ ------------------------------------------------------------------------------- import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text)+import Hedgehog ------------------------------------------------------------------------------- import SpecHelper -------------------------------------------------------------------------------@@ -175,7 +176,8 @@ describeSerializeParseCronSchedule :: TestTree describeSerializeParseCronSchedule = testGroup "serialize/parse CronSchedule" [- testProperty "roundtrips" $ \cs -> do+ testProperty "roundtrips" $ property $ do+ cs <- forAll gen parseCronSchedule (serializeCronSchedule cs) === Right cs ] @@ -184,7 +186,8 @@ describeSerializeParseCrontab :: TestTree describeSerializeParseCrontab = testGroup "serialize/parse Crontab" [- testProperty "roundtrips" $ \ct -> do+ testProperty "roundtrips" $ property $ do+ ct <- forAll gen parseCrontab (serializeCrontab ct) === Right ct ]
test/System/Test/Cron/Schedule.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module System.Test.Cron.Schedule ( tests ) where@@ -30,9 +32,10 @@ , testCase "should read all three jobs." $ length s @?= 3 ]- where Right ((), s) = runSchedule $ do addJob noop "* * * * *"- addJob noop "0 * * * *"- addJob noop "0 0 * * *"+ where ((), s) = either (error . show) id $ runSchedule $ do+ addJob noop "* * * * *"+ addJob noop "0 * * * *"+ addJob noop "0 0 * * *" noop = return () describeExecSchedule :: TestTree@@ -43,8 +46,7 @@ ] where fireAndWait = do v <- newEmptyMVar- tids <- execSchedule $ do- addJob (flipMVar v) "* * * * *"+ tids <- execSchedule $ addJob (flipMVar v) "* * * * *" threadDelay (1000000 * 60) mapM_ killThread tids takeMVar v