module System.Cron.Schedule
( Job (..)
, ScheduleError (..)
, Schedule
, ScheduleT (..)
, MonadSchedule (..)
, runSchedule
, runScheduleT
, execSchedule
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Concurrent
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.State
import Data.Attoparsec.Text (parseOnly)
import Data.Text (pack)
import Data.Time
import System.Cron
import System.Cron.Parser
#if !MIN_VERSION_time(1,5,0)
import System.Locale
#endif
readTime' :: TimeLocale -> String -> String -> UTCTime
#if MIN_VERSION_time(1,5,0)
readTime' = parseTimeOrError True
#else
readTime' = readTime
#endif
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
execSchedule :: Schedule () -> IO [ThreadId]
execSchedule s = let res = runSchedule s
in case res of
Left e -> print e >> return []
Right (_, jobs) -> mapM forkJob jobs
forkJob :: Job -> IO ThreadId
forkJob (Job s a) = forkIO $ forever $ do
(timeAt, delay) <- findNextMinuteDelay
threadDelay delay
when (scheduleMatches s timeAt) a
findNextMinuteDelay :: IO (UTCTime, Int)
findNextMinuteDelay = do
now <- getCurrentTime
let f = formatTime defaultTimeLocale fmtFront now
m = (read (formatTime defaultTimeLocale fmtMinutes now) :: Int) + 1
r = f ++ ":" ++ if length (show m) == 1 then "0" ++ show m else show m
next = readTime' defaultTimeLocale fmtRead r :: UTCTime
diff = diffUTCTime next now
delay = round (realToFrac (diff * 1000000) :: Double) :: Int
return (next, delay)
where fmtFront = "%F %H"
fmtMinutes = "%M"
fmtRead = "%F %H:%M"