{-# 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 -> String
show (Job CronSchedule
c IO ()
_) = String
"(Job " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CronSchedule -> String
forall a. Show a => a -> String
show CronSchedule
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"


-------------------------------------------------------------------------------
newtype ScheduleError = ParseError String
                   deriving (Int -> ScheduleError -> ShowS
[ScheduleError] -> ShowS
ScheduleError -> String
(Int -> ScheduleError -> ShowS)
-> (ScheduleError -> String)
-> ([ScheduleError] -> ShowS)
-> Show ScheduleError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScheduleError -> ShowS
showsPrec :: Int -> ScheduleError -> ShowS
$cshow :: ScheduleError -> String
show :: ScheduleError -> String
$cshowList :: [ScheduleError] -> ShowS
showList :: [ScheduleError] -> ShowS
Show)


-------------------------------------------------------------------------------
type Schedule = ScheduleT Identity


-------------------------------------------------------------------------------
newtype ScheduleT m a = ScheduleT { forall (m :: * -> *) a.
ScheduleT m a -> StateT [Job] (ExceptT ScheduleError m) a
unSchedule :: StateT Jobs (ExceptT ScheduleError m) a }
        deriving ( (forall a b. (a -> b) -> ScheduleT m a -> ScheduleT m b)
-> (forall a b. a -> ScheduleT m b -> ScheduleT m a)
-> Functor (ScheduleT m)
forall a b. a -> ScheduleT m b -> ScheduleT m a
forall a b. (a -> b) -> ScheduleT m a -> ScheduleT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ScheduleT m b -> ScheduleT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ScheduleT m a -> ScheduleT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ScheduleT m a -> ScheduleT m b
fmap :: forall a b. (a -> b) -> ScheduleT m a -> ScheduleT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ScheduleT m b -> ScheduleT m a
<$ :: forall a b. a -> ScheduleT m b -> ScheduleT m a
Functor, Functor (ScheduleT m)
Functor (ScheduleT m) =>
(forall a. a -> ScheduleT m a)
-> (forall a b.
    ScheduleT m (a -> b) -> ScheduleT m a -> ScheduleT m b)
-> (forall a b c.
    (a -> b -> c) -> ScheduleT m a -> ScheduleT m b -> ScheduleT m c)
-> (forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m b)
-> (forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m a)
-> Applicative (ScheduleT m)
forall a. a -> ScheduleT m a
forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m a
forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m b
forall a b. ScheduleT m (a -> b) -> ScheduleT m a -> ScheduleT m b
forall a b c.
(a -> b -> c) -> ScheduleT m a -> ScheduleT m b -> ScheduleT m c
forall (m :: * -> *). Monad m => Functor (ScheduleT m)
forall (m :: * -> *) a. Monad m => a -> ScheduleT m a
forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> ScheduleT m b -> ScheduleT m a
forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> ScheduleT m b -> ScheduleT m b
forall (m :: * -> *) a b.
Monad m =>
ScheduleT m (a -> b) -> ScheduleT m a -> ScheduleT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ScheduleT m a -> ScheduleT m b -> ScheduleT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> ScheduleT m a
pure :: forall a. a -> ScheduleT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
ScheduleT m (a -> b) -> ScheduleT m a -> ScheduleT m b
<*> :: forall a b. ScheduleT m (a -> b) -> ScheduleT m a -> ScheduleT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ScheduleT m a -> ScheduleT m b -> ScheduleT m c
liftA2 :: forall a b c.
(a -> b -> c) -> ScheduleT m a -> ScheduleT m b -> ScheduleT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> ScheduleT m b -> ScheduleT m b
*> :: forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> ScheduleT m b -> ScheduleT m a
<* :: forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m a
Applicative, Applicative (ScheduleT m)
Applicative (ScheduleT m) =>
(forall a b.
 ScheduleT m a -> (a -> ScheduleT m b) -> ScheduleT m b)
-> (forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m b)
-> (forall a. a -> ScheduleT m a)
-> Monad (ScheduleT m)
forall a. a -> ScheduleT m a
forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m b
forall a b. ScheduleT m a -> (a -> ScheduleT m b) -> ScheduleT m b
forall (m :: * -> *). Monad m => Applicative (ScheduleT m)
forall (m :: * -> *) a. Monad m => a -> ScheduleT m a
forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> ScheduleT m b -> ScheduleT m b
forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> (a -> ScheduleT m b) -> ScheduleT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> (a -> ScheduleT m b) -> ScheduleT m b
>>= :: forall a b. ScheduleT m a -> (a -> ScheduleT m b) -> ScheduleT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ScheduleT m a -> ScheduleT m b -> ScheduleT m b
>> :: forall a b. ScheduleT m a -> ScheduleT m b -> ScheduleT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ScheduleT m a
return :: forall a. a -> ScheduleT m a
Monad
                 , MonadState Jobs
                 , MonadError ScheduleError
                 )


-------------------------------------------------------------------------------
runSchedule :: Schedule a -> Either ScheduleError (a, [Job])
runSchedule :: forall a. Schedule a -> Either ScheduleError (a, [Job])
runSchedule = Identity (Either ScheduleError (a, [Job]))
-> Either ScheduleError (a, [Job])
forall a. Identity a -> a
runIdentity (Identity (Either ScheduleError (a, [Job]))
 -> Either ScheduleError (a, [Job]))
-> (Schedule a -> Identity (Either ScheduleError (a, [Job])))
-> Schedule a
-> Either ScheduleError (a, [Job])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schedule a -> Identity (Either ScheduleError (a, [Job]))
forall (m :: * -> *) a.
ScheduleT m a -> m (Either ScheduleError (a, [Job]))
runScheduleT


-------------------------------------------------------------------------------
runScheduleT :: ScheduleT m a -> m (Either ScheduleError (a, [Job]))
runScheduleT :: forall (m :: * -> *) a.
ScheduleT m a -> m (Either ScheduleError (a, [Job]))
runScheduleT = ExceptT ScheduleError m (a, [Job])
-> m (Either ScheduleError (a, [Job]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ScheduleError m (a, [Job])
 -> m (Either ScheduleError (a, [Job])))
-> (ScheduleT m a -> ExceptT ScheduleError m (a, [Job]))
-> ScheduleT m a
-> m (Either ScheduleError (a, [Job]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT [Job] (ExceptT ScheduleError m) a
 -> [Job] -> ExceptT ScheduleError m (a, [Job]))
-> [Job]
-> StateT [Job] (ExceptT ScheduleError m) a
-> ExceptT ScheduleError m (a, [Job])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [Job] (ExceptT ScheduleError m) a
-> [Job] -> ExceptT ScheduleError m (a, [Job])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT [] (StateT [Job] (ExceptT ScheduleError m) a
 -> ExceptT ScheduleError m (a, [Job]))
-> (ScheduleT m a -> StateT [Job] (ExceptT ScheduleError m) a)
-> ScheduleT m a
-> ExceptT ScheduleError m (a, [Job])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScheduleT m a -> StateT [Job] (ExceptT ScheduleError m) a
forall (m :: * -> *) a.
ScheduleT m a -> StateT [Job] (ExceptT ScheduleError m) a
unSchedule


-------------------------------------------------------------------------------
class MonadSchedule m where
    addJob ::  IO () -> Text -> m ()

instance (Monad m) => MonadSchedule (ScheduleT m) where
    addJob :: IO () -> Text -> ScheduleT m ()
addJob IO ()
a Text
t = do [Job]
s :: Jobs <- ScheduleT m [Job]
forall s (m :: * -> *). MonadState s m => m s
get
                    case Parser CronSchedule -> Text -> Either String CronSchedule
forall a. Parser a -> Text -> Either String a
parseOnly Parser CronSchedule
cronSchedule Text
t of
                        Left  String
e  -> ScheduleError -> ScheduleT m ()
forall a. ScheduleError -> ScheduleT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScheduleError -> ScheduleT m ())
-> ScheduleError -> ScheduleT m ()
forall a b. (a -> b) -> a -> b
$ String -> ScheduleError
ParseError String
e
                        Right CronSchedule
t' -> [Job] -> ScheduleT m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Job] -> ScheduleT m ()) -> [Job] -> ScheduleT m ()
forall a b. (a -> b) -> a -> b
$ CronSchedule -> IO () -> Job
Job CronSchedule
t' IO ()
a Job -> [Job] -> [Job]
forall a. a -> [a] -> [a]
: [Job]
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 :: Schedule () -> IO [ThreadId]
execSchedule Schedule ()
s = let res :: Either ScheduleError ((), [Job])
res = Schedule () -> Either ScheduleError ((), [Job])
forall a. Schedule a -> Either ScheduleError (a, [Job])
runSchedule Schedule ()
s
                  in case Either ScheduleError ((), [Job])
res of
                        Left  ScheduleError
e         -> ScheduleError -> IO ()
forall a. Show a => a -> IO ()
print ScheduleError
e IO () -> IO [ThreadId] -> IO [ThreadId]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ThreadId] -> IO [ThreadId]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                        Right (()
_, [Job]
jobs) -> (Job -> IO ThreadId) -> [Job] -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Job -> IO ThreadId
forkJob [Job]
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 -> IO ThreadId
forkJob (Job CronSchedule
s IO ()
a) = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (UTCTime
timeAt, Int
delay) <- IO (UTCTime, Int)
findNextMinuteDelay
            Int -> IO ()
threadDelay Int
delay
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CronSchedule -> UTCTime -> Bool
scheduleMatches CronSchedule
s UTCTime
timeAt) (IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
a)


-------------------------------------------------------------------------------
findNextMinuteDelay :: IO (UTCTime, Int)
findNextMinuteDelay :: IO (UTCTime, Int)
findNextMinuteDelay = UTCTime -> (UTCTime, Int)
findNextMinuteDelay' (UTCTime -> (UTCTime, Int)) -> IO UTCTime -> IO (UTCTime, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime