cron 0.2.2 → 0.2.3

raw patch · 4 files changed

+154/−8 lines, 4 filesdep +mtldep +old-localedep +transformersdep ~hspecdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, old-locale, transformers

Dependency ranges changed: hspec, time

API changes (from Hackage documentation)

Files

• README.md +21/−0
• changelog +2/−0
• cron.cabal +12/−8
• src/System/Cron/Schedule.hs +119/−0

@@ -31,7 +31,28 @@      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)

@@ -1,3 +1,5 @@+# 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

@@ -1,5 +1,5 @@ Name:                cron-Version:             0.2.2+Version:             0.2.3 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@@ -34,27 +34,31 @@  library  Exposed-modules: System.Cron,-                  System.Cron.Parser+                  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+                  time            >= 1.4,+                  old-locale      >= 1.0,+                  mtl             >= 2.2  test-suite spec   Type:           exitcode-stdio-1.0   Main-Is:        Spec.hs   Hs-Source-Dirs: test-  Build-Depends:  base >= 4 && < 5,+  Build-Depends:  base                  >= 4 && < 5,                   cron,-                  hspec == 1.3.*,+                  hspec                 >= 1.3,                   QuickCheck,                   derive,                   hspec-expectations,-                  attoparsec      >= 0.10,-                  text            >= 0.11 && < 2,-                  time            >= 1.4+                  attoparsec            >= 0.10,+                  text                  >= 0.11 && < 2,+                  time                  >= 1.4,+                  transformers          >= 0.4  source-repository head   Type:     git

@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}++--------------------------------------------------------------------+-- |+-- 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++import           Control.Applicative+import           Control.Concurrent+import           Control.Monad.Except+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+import           System.Locale++{- 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+            now <- getCurrentTime+            findNextMinuteDelay >>= threadDelay+            when (scheduleMatches s now) a++findNextMinuteDelay :: IO 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+        newNow <- getCurrentTime    -- Compensates for the time spent calculating what the next minute is.+        let diff  = diffUTCTime next newNow+            delay = round (realToFrac (diff * 1000000) :: Double) :: Int+        return delay+    where fmtFront   = "%F %H"+          fmtMinutes = "%M"+          fmtRead    = "%F %H:%M"