Schedule.hs

{-# LANGUAGE CPP                        #-}
{-# 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 (..)
    , forkJob
    , 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 (forever, when, void)
import           Control.Monad.Except
import           Control.Monad.Identity
import           Control.Monad.State
import           Data.Attoparsec.Text       (parseOnly)
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
-------------------------------------------------------------------------------


-- | Scheduling Monad
data Job = Job CronSchedule (IO ())

-------------------------------------------------------------------------------
type Jobs = [Job]


instance Show Job where
    show (Job c _) = "(Job " ++ show c ++ ")"


-------------------------------------------------------------------------------
newtype 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 () -> Text -> m ()

instance (Monad m) => MonadSchedule (ScheduleT m) where
    addJob a t = do s :: Jobs <- get
                    case parseOnly cronSchedule t of
                        Left  e  -> throwError $ ParseError e
                        Right t' -> put $ Job t' a : s


-------------------------------------------------------------------------------
-- Monitoring engine
-------------------------------------------------------------------------------


-- | Schedule all of the jobs to run at appropriate intervals. Each
-- job that is launched gets a scheduling thread to itself. Each
-- time a scheduling thread launches a job, the job is forked onto
-- a new thread. This means that if a job throws an excpetion in IO,
-- its thread will be killed, but it will continue to be scheduled
-- in the future.
execSchedule :: Schedule () -> IO [ThreadId]
execSchedule s = let res = runSchedule s
                  in case res of
                        Left  e         -> print e >> return []
                        Right (_, jobs) -> mapM forkJob jobs


-------------------------------------------------------------------------------
-- | Start a job-runner thread that runs a job at appropriate
-- intervals. Each time it is run, a new thread is forked for it,
-- meaning that a single exception does not take down the
-- scheduler.
forkJob :: Job -> IO ThreadId
forkJob (Job s a) = forkIO $ forever $ do
            (timeAt, delay) <- findNextMinuteDelay
            threadDelay delay
            when (scheduleMatches s timeAt) (void $ forkIO a)


-------------------------------------------------------------------------------
findNextMinuteDelay :: IO (UTCTime, Int)
findNextMinuteDelay = findNextMinuteDelay' <$> getCurrentTime