diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -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 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 diff --git a/src/System/Cron/Internal/Check.hs b/src/System/Cron/Internal/Check.hs --- a/src/System/Cron/Internal/Check.hs +++ b/src/System/Cron/Internal/Check.hs @@ -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 diff --git a/src/System/Cron/Internal/Describe/Options.hs b/src/System/Cron/Internal/Describe/Options.hs --- a/src/System/Cron/Internal/Describe/Options.hs +++ b/src/System/Cron/Internal/Describe/Options.hs @@ -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 diff --git a/src/System/Cron/Internal/Schedule.hs b/src/System/Cron/Internal/Schedule.hs new file mode 100644 --- /dev/null +++ b/src/System/Cron/Internal/Schedule.hs @@ -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) diff --git a/src/System/Cron/Parser.hs b/src/System/Cron/Parser.hs --- a/src/System/Cron/Parser.hs +++ b/src/System/Cron/Parser.hs @@ -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 diff --git a/src/System/Cron/Schedule.hs b/src/System/Cron/Schedule.hs --- a/src/System/Cron/Schedule.hs +++ b/src/System/Cron/Schedule.hs @@ -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 diff --git a/src/System/Cron/Types.hs b/src/System/Cron/Types.hs --- a/src/System/Cron/Types.hs +++ b/src/System/Cron/Types.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 --- -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 diff --git a/test/System/Test/Cron.hs b/test/System/Test/Cron.hs --- a/test/System/Test/Cron.hs +++ b/test/System/Test/Cron.hs @@ -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)} diff --git a/test/System/Test/Cron/Describe.hs b/test/System/Test/Cron/Describe.hs --- a/test/System/Test/Cron/Describe.hs +++ b/test/System/Test/Cron/Describe.hs @@ -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 diff --git a/test/System/Test/Cron/Internal/Schedule.hs b/test/System/Test/Cron/Internal/Schedule.hs new file mode 100644 --- /dev/null +++ b/test/System/Test/Cron/Internal/Schedule.hs @@ -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 + ] diff --git a/test/System/Test/Cron/Parser.hs b/test/System/Test/Cron/Parser.hs --- a/test/System/Test/Cron/Parser.hs +++ b/test/System/Test/Cron/Parser.hs @@ -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 ] diff --git a/test/System/Test/Cron/Schedule.hs b/test/System/Test/Cron/Schedule.hs --- a/test/System/Test/Cron/Schedule.hs +++ b/test/System/Test/Cron/Schedule.hs @@ -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