hcron (empty) → 0.0.0.2

raw patch · 5 files changed

+325/−0 lines, 5 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, directory, mtl, old-locale, pretty, process, random, stm, time

Files

• HCron.hs +43/−0
• HCron/Schedule.hs +209/−0
• LICENSE +25/−0
• Setup.hs +3/−0
• hcron.cabal +45/−0

@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | A simple ''cron'' loop. Used for running commands according to a given schedule.+module HCron+	( module HCron.Schedule+	, cronLoop )+where+import HCron.Schedule+import Control.Concurrent+import Data.Time++-- | Given a schedule of commands, run them when their time is due.+--   Only one command is run at a time. If several commands could be started at a specific+--   moment, then we take the one with the earliest potential start time. If any command throws+--   an error then the whole loop does.+--+cronLoop :: Schedule (IO ()) -> IO ()+cronLoop schedule = do+	startTime <- getCurrentTime++	case earliestEventToStartAt startTime $ eventsOfSchedule schedule of+		Nothing -> do+			sleep 1+			cronLoop schedule++		Just event -> do+			let Just cmd = lookupCommandOfSchedule (eventName event) schedule+			cmd+			endTime <- getCurrentTime++			let event' = event+				{ eventLastStarted = Just startTime+				, eventLastEnded = Just endTime }++			let schedule' = adjustEventOfSchedule event' schedule++			cronLoop schedule'++-- | Sleep for a given number of seconds.+sleep :: Int -> IO ()+sleep secs+	= threadDelay $ secs * 1000000

@@ -0,0 +1,209 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | A schedule of commands that should be run at a certain time.+module HCron.Schedule+	-- * Time Periods+	( second, minute, hour, day++	-- * When+	, When (..)+	, WhenModifier (..)++	-- * Events+	, EventName+	, Event (..)+	, earliestEventToStartAt+	, eventCouldStartAt++	-- * Schedules+	, Schedule (..)+	, makeSchedule+	, lookupEventOfSchedule+	, lookupCommandOfSchedule+	, adjustEventOfSchedule+	, eventsOfSchedule)+where++import Data.Time+import Data.List+import Data.Function+import Data.Maybe+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map++instance Read NominalDiffTime where+	readsPrec n str = let [(secs :: Double, rest)] = readsPrec n str in+		case rest of+			's' : rest' -> [(fromRational $ toRational secs, rest')]+			_ -> []++second, minute, hour, day :: NominalDiffTime+second = 1+minute = 60+hour = 60 * minute+day = 24 * hour++-- When -------------------------------------------------------------------------------------------+-- | When to invoke some event.+data When+	-- | Just keep doing it.+	= Always++	-- | Don't do it, ever.+	| Never++	-- | Do it some time after we last started it.+	| Every NominalDiffTime+	+	-- | Do it some time after it last finished.+	| After NominalDiffTime+	+	-- | Do it each day at this time. The ''days'' are UTC days, not local ones.+	| Daily TimeOfDay+	deriving (Read, Show, Eq)+++-- | Modifier to when.+data WhenModifier+	-- | If the event hasn't been invoked before then do it immediately+	--   when we start the cron process.+	= Immediate++	-- | Wait until after this time before doing it first.+	| WaitUntil UTCTime+	deriving (Read, Show, Eq)+++-- Event ------------------------------------------------------------------------------------------+type EventName = String++-- | Records when an event should start, and when it last ran.+data Event+	= Event+	{ -- | A unique name for this event.+	  --   Used when writing the schedule to a file.+	  eventName :: EventName++	  -- | When to run the command.+	, eventWhen :: When++	  -- | Modifier to the previous.+	, eventWhenModifier :: Maybe WhenModifier++	  -- | When the event was last started, if any.+	, eventLastStarted :: Maybe UTCTime+		+	  -- | When the event last finished, if any.+	, eventLastEnded :: Maybe UTCTime }+	deriving (Read, Show, Eq)+++-- | Given the current time and a list of events, determine which one should be started now.+--   If several events are avaliable then take the one with the earliest start time.+earliestEventToStartAt :: UTCTime -> [Event] -> Maybe Event+earliestEventToStartAt curTime events = let+	eventsStartable = filter (eventCouldStartAt curTime) events+	eventsSorted = sortBy (compare `on` eventLastStarted) eventsStartable+	in listToMaybe eventsSorted+++-- | Given the current time, decide whether an event could be started.+--   If the `WhenModifier` is `Immediate` this always returns true.+--   The `SkipFirst` modifier is ignored, as this is handled separately.+eventCouldStartAt :: UTCTime -> Event -> Bool+eventCouldStartAt curTime event+	-- If the event has never started or ended, and is marked as immediate,+	-- then start it right away.+	| Nothing <- eventLastStarted  event+	, Nothing <- eventLastEnded    event+	, Just Immediate	<- eventWhenModifier event+	= True++	-- If the current end time is before the start time, then the most+	-- recent iteration is still running, so don't start it again.+	| Just lastStarted <- eventLastStarted event+	, Just lastEnded <- eventLastEnded   event+	, lastEnded < lastStarted+	= False++	-- Keep waiting if there's a seconday wait modifier.+	| Just (WaitUntil waitTime) <- eventWhenModifier event+	, curTime < waitTime+	= False++	-- Otherwise we have to look at the real schedule.+	| otherwise+	= case eventWhen event of+		Always -> True+		Never -> False++		Every diffTime+		 -> maybe True+			(\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)+			(eventLastStarted event)++		After diffTime+		 -> maybe True+			(\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)+			(eventLastEnded event)+	+		Daily timeOfDay+		 -- If it's been less than a day since we last started it, then don't do it yet.+		 | Just lastStarted	<- eventLastStarted event+		 , (curTime `diffUTCTime` lastStarted) < day+		 -> False+		+		 | otherwise+		 -> let -- If we were going to run it today, this is when it would be.+			startTimeToday+				= curTime+				{ utctDayTime	= timeOfDayToTime timeOfDay }+				+			-- If it's after that time then quit fooling around..+			in curTime > startTimeToday+++-- Schedule ---------------------------------------------------------------------------------------+-- | Map of event names to their details and build commands.	+data Schedule cmd+	= Schedule (Map EventName (Event, cmd))+++-- | Get the list of events in a schedule, ignoring the build commands.+eventsOfSchedule :: Schedule cmd -> [Event]+eventsOfSchedule (Schedule sched)+	= map fst $ Map.elems sched+++-- | A nice way to produce a schedule.+makeSchedule :: [(EventName, When, Maybe WhenModifier, cmd)] -> Schedule cmd+makeSchedule tuples+ = let makeSched (name, whn, mMod, cmd)+		= (name, (Event name whn mMod Nothing Nothing, cmd))+   in Schedule $ Map.fromList $ map makeSched tuples+++-- | Given an event name, lookup the associated event from a schedule.+lookupEventOfSchedule :: EventName -> Schedule cmd -> Maybe Event+lookupEventOfSchedule name (Schedule sched)+	= liftM fst $ Map.lookup name sched+++-- | Given an event name, lookup the associated build command from a schedule.+lookupCommandOfSchedule :: EventName -> Schedule cmd -> Maybe cmd+lookupCommandOfSchedule name (Schedule sched)+	= liftM snd $ Map.lookup name sched+++-- | Given a new version of an event, update any matching event in the schedule.+--   If the event not already there then return the original schedule.+adjustEventOfSchedule :: Event -> Schedule cmd -> Schedule cmd+adjustEventOfSchedule event (Schedule sched)+	= Schedule +	$ Map.adjust +		(\(_, build) -> (event, build))+		(eventName event) +		sched+

@@ -0,0 +1,25 @@+Copyright (c) 2010, University of New South Wales.+Copyright (c) 2011, Timo B. Hübel+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the University of New South Wales nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+

@@ -0,0 +1,45 @@+Name:                hcron+Version:             0.0.0.2+License:             BSD3+License-file:        LICENSE+Author:              Timo B. Kranz+Maintainer:          Timo B. Kranz <me@tbk.name>+Build-Type:          Simple+Cabal-Version:       >=1.6+Stability:           experimental+Category:            Control, Scheduling+Homepage:            http://github.com/tbh/hcron+Description:+  A simple job scheduler for Haskell, which just runs some IO () action at a given time.++  Currently almost all of this package is based on the excellent cron modules found in the+  BuildBox package by Ben Lippmeier.++Synopsis:+  A simple job scheduler, which just runs some IO action at a given time.++Tested-with:+        GHC == 7.0.3++Library+  Build-Depends: +        base           == 4.*,+        containers     >= 0.4    && <  0.5,+        time           >= 1.1    && <= 1.3,+        directory      >= 1.0    && <= 1.2,+        mtl            >= 2.0    && <  3.0,+        old-locale     == 1.0.*,+        process        == 1.0.*,+        random         == 1.0.*,+        pretty         == 1.0.*,+        bytestring     == 0.9.*,+        stm            == 2.2.*++  ghc-options:+        -Wall++  Exposed-modules:+        HCron+        HCron.Schedule++  Other-modules: