* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+open CalendarLib
+
open Unix
open Printf
let target_exists vs = target (List.fold_left (||) false vs)
let require () = ()
+type period_t = Seconds | Days | Months | Years
+let seconds = (1, Seconds)
+let sec = seconds and secs = seconds and second = seconds
+let minutes = (60, Seconds)
+let min = minutes and mins = minutes and minute = minutes
+let hours = (3600, Seconds)
+let hour = hours
+let days = (1, Days)
+let day = days
+let weeks = (7, Days)
+let week = weeks
+let months = (1, Months)
+let month = months
+let years = (1, Years)
+let year = years
+
+let periodic_jobs = ref []
+
+(* Register a periodic job. *)
+let every ?name i (j, t) f =
+ let period = i*j, t in (* 5 minutes -> ((5 * 60), Seconds) *)
+ periodic_jobs := (period, name, f) :: !periodic_jobs
+
+(* [next_time t period] returns the earliest event of [period]
+ strictly after time [t].
+
+ Visualising periods as repeated events on a timeline, this
+ returns [t']:
+
+ {v
+ events: ---+---------+---------+---------+---------+---------+-----
+ times: t t'
+ }
+
+ Note that [period_t] events are not necessarily regular.
+ eg. The start of a month is not a fixed number of seconds
+ after the start of the previous month. 'Epoch' refers
+ to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
+
+ If [period = i, Seconds i] then events are when
+ [t' mod i == 0] when t' is the number of seconds since
+ the Epoch. This returns the next t' > t.
+
+ If [period = i, Days] then events happen at
+ midnight UTC every [i] days since the Epoch.
+ This returns the next midnight > t.
+
+ If [period = i, Months] then events happen at
+ midnight UTC on the 1st day of the month every [i] months
+ since the Epoch. This returns midnight on the
+ 1st day of the next month > t.
+
+ If [period = i, Years] then events happen at
+ midnight UTC on the 1st day of the year when
+ [(y - 1970) mod i == 0]. This returns midnight on the
+ 1st day of the next year > t. *)
+
+let next_time =
+ (* Round up 'a' to the next multiple of 'i'. *)
+ let round_up_float a i =
+ let r = mod_float a i in
+ if r = 0. then a +. i else a +. (i -. r)
+ and round_up a i =
+ let r = a mod i in
+ if r = 0 then a + i else a + (i - r)
+ in
+
+ fun t -> function
+ | (i, Seconds) ->
+ let i = float_of_int i in
+ round_up_float t i
+
+ | (i, Years) ->
+ let tm = gmtime t in
+
+ (* Round 'tm' up to the first day of the next year. *)
+ let year = round_up tm.tm_year i in
+ let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
+ tm_mday = 1; tm_mon = 0; tm_year = year } in
+ fst (mktime tm)
+
+ | (i, Days) ->
+ let t = Date.from_unixfloat t in
+ let t0 = Date.make 1970 1 1 in
+
+ (* Number of whole days since Unix Epoch. *)
+ let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
+
+ let nb_days = round_up nb_days i in
+ let t' = Date.add t0 (Date.Period.day nb_days) in
+ Date.to_unixfloat t'
+
+ | (i, Months) ->
+ (* Calculate number of whole months since Unix Epoch. *)
+ let tm = gmtime t in
+ let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
+
+ let months = round_up months i in
+ let t0 = Date.make 1970 1 1 in
+ let t' = Date.add t0 (Date.Period.month months) in
+ Date.to_unixfloat t'
+
let file_exists = Sys.file_exists
+let directory_exists path =
+ let s =
+ try Some (stat path)
+ with
+ | Unix_error (ENOENT, _, _) -> None
+ | Unix_error (err, _, _) ->
+ let msg = sprintf "directory_exists: %s: %s" path (error_message err) in
+ goal_failed msg in
+ match s with
+ | Some s -> s.st_kind = S_DIR
+ | None -> false
+
let file_newer_than f1 f2 =
let stat f =
try Some (stat f)
exit 1
)
| [] ->
- (* Does a published 'all' goal exist? *)
- match get_goal "all" with
- | Some fn -> fn []
- | None ->
- (* No published 'all' goal. This is only a warning, because
- * other top-level code may exist in the script.
- *)
- eprintf "warning: no 'all' goal found.\n"
+ (* If periodic jobs exist, fall through. *)
+ if !periodic_jobs = [] then (
+ (* Does a published 'all' goal exist? *)
+ match get_goal "all" with
+ | Some fn ->
+ exit (if guard fn [] then 0 else 1)
+ | None ->
+ (* No published 'all' goal. *)
+ eprintf "error: no goal called 'all' was found.\n";
+ exit 1
+ )
+ );
+
+ assert (!periodic_jobs <> []);
+
+ (* Run the periodic jobs. Note these run forever, or until killed. *)
+ while true do
+ (* Find the next job to run. *)
+ let now = time () in
+ let next = List.map (
+ fun (period, name, f) ->
+ next_time now period, name, f
+ ) !periodic_jobs in
+ let next = List.sort (fun (t1,_,_) (t2,_,_) -> compare t1 t2) next in
+ let next_t, name, f = List.hd next in
+
+ let name = match name with Some name -> name | None -> "[unnamed]" in
+
+ (* Run it after waiting for the appropriate amount of time. *)
+ let seconds = int_of_float (next_t -. now) in
+ eprintf "next job '%s' will run in %s\n%!" name (printable_seconds seconds);
+ sleep seconds;
+ ignore (guard f ())
+ done
+
+and printable_seconds s =
+ if s < 60 then sprintf "%d seconds" s
+ else if s < 6000 then sprintf "%d minutes, %d seconds" (s/60) (s mod 60)
+ else if s < 86400 then sprintf "%d hours, %d minutes" (s/3600) (s/60)
+ else sprintf "about %d days" (s/86400)
the requirements of a rule can be placed anywhere within the
rule, as long as you put them before they are needed. *)
+(** {2 Periodic jobs}
+
+ If you want to have a rule that runs when some outside event
+ happens you have three choices: Manually run the script (this is
+ basically what [make] forces you to do). Have some sort of hook
+ that runs the script (eg. a git hook). Or use a periodic job to
+ poll for an event or change.
+
+ Periodic jobs run regularly to poll for an outside event or
+ change. If a script has periodic jobs, then it runs continuously
+ (or until you kill it).
+
+ An example of a script that checks for new git commits and when
+ it sees one it will ensure it passes the tests:
+
+ {v
+ let repo = Sys.getenv "HOME" // "repo"
+
+ let goal git_commit_tested commit =
+ let key = sprintf "repo-tested-%s" commit in
+ target (memory_exists key);
+
+ sh "
+ git clone %s test
+ cd test
+ ./configure
+ make
+ make check
+ ";
+
+ (* Record that this commit was tested successfully. *)
+ memory_set key "1"
+
+ every 30 minutes (fun () ->
+ let commit = shout "cd %s && git rev-parse HEAD" repo in
+ (* Require that this commit has been tested. *)
+ require (git_commit_tested commit)
+ )
+ }
+
+ Some notes about the above example: Firstly only the current HEAD
+ commit is required to be tested. This is because older commits
+ are irrelevant and because if they failed the test before there is
+ not point retesting them (commits are immutable). Secondly we use
+ the Memory to remember that we have successfully tested a commit.
+ This is what stops the program from repeatedly testing the same
+ commit. *)
+
+(* This is what lets you write '30 minutes' etc: *)
+type period_t = Seconds | Days | Months | Years
+val seconds : int * period_t
+val sec : int * period_t
+val secs : int * period_t
+val second : int * period_t
+val minutes : int * period_t
+val min : int * period_t
+val mins : int * period_t
+val minute : int * period_t
+val hours : int * period_t
+val hour : int * period_t
+val days : int * period_t
+val day : int * period_t
+val weeks : int * period_t
+val week : int * period_t
+val months : int * period_t
+val month : int * period_t
+val years : int * period_t
+val year : int * period_t
+
+val every : ?name:string -> int -> int * period_t -> (unit -> unit) -> unit
+ (** [every N (seconds|minutes|hours|days|weeks|months|years) f]
+ runs the function [f] periodically.
+
+ The optional [~name] parameter can be used to name the job
+ (for debugging). *)
+
(** {2 File and URL testing}
Various functions to test the existence of files, URLs.
git.annexia.org / goaljobs.git / commitdiff