diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +# 0.7.0 +* Fix time parsing error (#41), Julien Debon (@Sir4ur0n) # 0.6.2 * Updates to allow GHC 8.8 # 0.6.1 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -1,5 +1,5 @@ Name: cron -Version: 0.6.2 +Version: 0.7.0 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 @@ -49,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 @@ -80,6 +81,7 @@ , System.Test.Cron.Describe , System.Test.Cron.Parser , System.Test.Cron.Schedule + , System.Test.Cron.Internal.Schedule Build-Depends: base , cron , tasty 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/Schedule.hs b/src/System/Cron/Schedule.hs --- a/src/System/Cron/Schedule.hs +++ b/src/System/Cron/Schedule.hs @@ -60,21 +60,12 @@ #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 +78,7 @@ ------------------------------------------------------------------------------- -data ScheduleError = ParseError String +newtype ScheduleError = ParseError String deriving (Show) @@ -156,15 +147,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/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 @@ -4,7 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} + module SpecHelper ( module X , module SpecHelper @@ -18,8 +18,10 @@ import Data.Maybe as X import Data.Monoid as X import Data.Text (Text) -import Data.Time.Calendar as X (fromGregorian, toGregorian) +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 @@ -114,8 +116,7 @@ genPOSIXTime :: Range.Range Int -> Gen POSIX.POSIXTime -genPOSIXTime rnge = do - fromInteger . toInteger <$> Gen.int rnge +genPOSIXTime rnge = fromInteger . toInteger <$> Gen.int rnge mkMinuteSpec' :: CronField -> MinuteSpec 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/Schedule.hs b/test/System/Test/Cron/Schedule.hs --- a/test/System/Test/Cron/Schedule.hs +++ b/test/System/Test/Cron/Schedule.hs @@ -45,8 +45,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