2 * Copyright (C) 2013 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
26 type ('a, 'b) alternative = Either of 'a | Or of 'b
28 let (//) = Filename.concat
29 let quote = Filename.quote
31 type goal_result_t = Goal_OK | Goal_failed of string
32 exception Goal_result of goal_result_t
34 let goal_failed msg = raise (Goal_result (Goal_failed msg))
37 if v then raise (Goal_result Goal_OK)
38 let target_all vs = target (List.fold_left (&&) true vs)
39 let target_exists vs = target (List.fold_left (||) false vs)
42 type period_t = Seconds | Days | Months | Years
43 let seconds = (1, Seconds)
44 let sec = seconds and secs = seconds and second = seconds
45 let minutes = (60, Seconds)
46 let min = minutes and mins = minutes and minute = minutes
47 let hours = (3600, Seconds)
53 let months = (1, Months)
55 let years = (1, Years)
58 let periodic_jobs = ref []
60 (* Register a periodic job. *)
61 let every ?name i (j, t) f =
62 let period = i*j, t in (* 5 minutes -> ((5 * 60), Seconds) *)
63 periodic_jobs := (period, (name, f)) :: !periodic_jobs
65 (* [next_time t period] returns the earliest event of [period]
66 strictly after time [t].
68 Visualising periods as repeated events on a timeline, this
72 events: ---+---------+---------+---------+---------+---------+-----
76 Note that [period_t] events are not necessarily regular.
77 eg. The start of a month is not a fixed number of seconds
78 after the start of the previous month. 'Epoch' refers
79 to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
81 If [period = i, Seconds i] then events are when
82 [t' mod i == 0] when t' is the number of seconds since
83 the Epoch. This returns the next t' > t.
85 If [period = i, Days] then events happen at
86 midnight UTC every [i] days since the Epoch.
87 This returns the next midnight > t.
89 If [period = i, Months] then events happen at
90 midnight UTC on the 1st day of the month every [i] months
91 since the Epoch. This returns midnight on the
92 1st day of the next month > t.
94 If [period = i, Years] then events happen at
95 midnight UTC on the 1st day of the year when
96 [(y - 1970) mod i == 0]. This returns midnight on the
97 1st day of the next year > t. *)
100 (* Round up 'a' to the next multiple of 'i'. *)
101 let round_up_float a i =
102 let r = mod_float a i in
103 if r = 0. then a +. i else a +. (i -. r)
106 if r = 0 then a + i else a + (i - r)
111 let i = float_of_int i in
117 (* Round 'tm' up to the first day of the next year. *)
118 let year = round_up tm.tm_year i in
119 let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
120 tm_mday = 1; tm_mon = 0; tm_year = year } in
124 let t = Date.from_unixfloat t in
125 let t0 = Date.make 1970 1 1 in
127 (* Number of whole days since Unix Epoch. *)
128 let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
130 let nb_days = round_up nb_days i in
131 let t' = Date.add t0 (Date.Period.day nb_days) in
135 (* Calculate number of whole months since Unix Epoch. *)
137 let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
139 let months = round_up months i in
140 let t0 = Date.make 1970 1 1 in
141 let t' = Date.add t0 (Date.Period.month months) in
144 let file_exists = Sys.file_exists
146 let directory_exists path =
150 | Unix_error (ENOENT, _, _) -> None
151 | Unix_error (err, _, _) ->
152 let msg = sprintf "directory_exists: %s: %s" path (error_message err) in
155 | Some s -> s.st_kind = S_DIR
158 let file_newer_than f1 f2 =
162 | Unix_error (ENOENT, _, _) -> None
163 | Unix_error (err, _, _) ->
164 let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
167 let s1 = stat f1 and s2 = stat f2 in
173 let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
176 s1.st_mtime >= s2.st_mtime
178 let more_recent objs srcs =
179 if not (List.for_all file_exists objs) then false
182 fun obj -> List.for_all (file_newer_than obj) srcs
187 (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
189 sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
190 match Sys.command cmd with
194 let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
198 let file_contains_string filename str =
199 let cmd = sprintf "grep -q %s %s" (quote str) (quote filename) in
200 match Sys.command cmd with
204 let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
208 let url_contains_string url str =
209 let tmp = Filename.temp_file "goaljobsurl" "" in
211 sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
212 (match Sys.command cmd with
215 let msg = sprintf "curl failed to download URL '%s'" url in
218 let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
222 let r = file_contains_string tmp str in
226 (* Create a temporary directory. It is *not* deleted on exit. *)
228 let chan = open_in "/dev/urandom" in
229 let data = String.create 16 in
230 really_input chan data 0 (String.length data);
232 let data = Digest.to_hex (Digest.string data) in
233 let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
237 (* Recursively remove directory. *)
239 let cmd = sprintf "rm -rf %s" (quote dir) in
240 ignore (Sys.command cmd)
242 let shell = ref "/bin/sh"
244 (* Used by sh, shout, shlines to handle the script and temporary dir. *)
245 let with_script ?(tmpdir = true) script f =
246 let dir = if tmpdir then Some (make_tmpdir ()) else None in
247 let script_file, chan =
250 let script_file = dir // "script.sh" in
251 let chan = open_out script_file in
253 | None -> Filename.open_temp_file "goaljobsscript" ".sh" in
254 chmod script_file 0o700;
255 fprintf chan "#!%s\n" !shell;
256 fprintf chan "set -e\n"; (* so that job exits on error *)
257 fprintf chan "set -x\n"; (* echo commands (must be last) *)
259 output_string chan script;
263 | Some dir -> sprintf "cd %s && exec %s" (quote dir) (quote script_file)
264 | None -> sprintf "exec %s" (quote script_file) in
265 let r = try Either (f cmd) with exn -> Or exn in
267 | Some dir -> rm_rf dir
272 | Or exn -> raise exn
276 with_script ?tmpdir script (
278 let r = Sys.command cmd in
280 let msg = sprintf "external command failed with code %d" r in
287 let do_shlines ?tmpdir script =
288 with_script ?tmpdir script (
290 let chan = open_process_in cmd in
291 let lines = ref [] in
293 let line = input_line chan in
294 eprintf "%s\n%!" line;
295 lines := line :: !lines;
298 (try loop () with End_of_file -> ());
299 match close_process_in chan with
300 | WEXITED 0 -> List.rev !lines
302 let msg = sprintf "external command failed with code %d" i in
305 let msg = sprintf "external command was killed by signal %d" i in
308 let msg = sprintf "external command was stopped by signal %d" i in
311 let shlines ?tmpdir fs = ksprintf (do_shlines ?tmpdir) fs
313 let do_shout ?tmpdir script =
314 let lines = do_shlines ?tmpdir script in
315 String.concat "\n" lines
316 let shout ?tmpdir fs = ksprintf (do_shout ?tmpdir) fs
319 val replace_substring : string -> string -> string -> string
322 let change_file_extension ext filename =
324 try String.rindex filename '.'
325 with Not_found -> String.length filename in
326 String.sub filename 0 i ^ "." ^ ext
329 val filter_file_extension : string -> string list -> string
332 (* Persistent memory is stored in $HOME/.goaljobs-memory. We have to
333 * lock this file each time we read or write because multiple concurrent
334 * jobs may access it at the same time.
336 * XXX Replace this with a more efficient and less fragile implementation.
339 let with_memory_locked ?(write = false) f =
340 let filename = getenv "HOME" // ".goaljobs-memory" in
341 let fd = openfile filename [O_RDWR; O_CREAT] 0o644 in
342 lockf fd (if write then F_LOCK else F_RLOCK) 0;
344 (* If the file is newly created with zero size, write an
347 if (fstat fd).st_size = 0 then (
348 let empty : (string, string) Hashtbl.t = Hashtbl.create 13 in
349 let chan = out_channel_of_descr fd in
350 output_value chan empty;
351 Pervasives.flush chan;
352 ignore (lseek fd 0 SEEK_SET)
355 (* Run the function. *)
356 let r = try Either (f fd) with exn -> Or exn in
361 | Or exn -> raise exn
363 let memory_exists key =
366 let chan = in_channel_of_descr fd in
367 let memory : (string, string) Hashtbl.t = input_value chan in
368 Hashtbl.mem memory key
374 let chan = in_channel_of_descr fd in
375 let memory : (string, string) Hashtbl.t = input_value chan in
376 try Some (Hashtbl.find memory key) with Not_found -> None
379 let memory_set key value =
380 with_memory_locked ~write:true (
382 let chan = in_channel_of_descr fd in
383 let memory : (string, string) Hashtbl.t = input_value chan in
384 Hashtbl.replace memory key value;
385 let chan = out_channel_of_descr fd in
387 output_value chan memory;
388 Pervasives.flush chan;
391 let memory_delete key =
392 with_memory_locked ~write:true (
394 let chan = in_channel_of_descr fd in
395 let memory : (string, string) Hashtbl.t = input_value chan in
396 Hashtbl.remove memory key;
397 let chan = out_channel_of_descr fd in
399 output_value chan memory;
400 Pervasives.flush chan;
403 let published_goals = ref []
404 let publish name fn = published_goals := (name, fn) :: !published_goals
406 try Some (List.assoc name !published_goals) with Not_found -> None
408 let log_program_output () =
409 let filename = Filename.temp_file "goaljobslog" ".txt" in
410 let cmd = "tee " ^ quote filename in
411 let chan = open_process_out cmd in
412 let fd = descr_of_out_channel chan in
417 let mailto ?from ~subject ?(attach = []) to_ =
418 let cmd = ref (sprintf "%s -s %s" mailx (quote subject)) in
421 | Some f -> cmd := !cmd ^ " -r " ^ quote f
424 fun a -> cmd := !cmd ^ " -a " ^ quote a
426 cmd := !cmd ^ " " ^ quote to_;
427 if Sys.command !cmd <> 0 then
428 goal_failed "mailto: could not send email"
430 let goal_file_exists filename =
431 if not (file_exists filename) then (
432 let msg = sprintf "file '%s' required but not found" filename in
435 let goal_directory_exists path =
436 if not (directory_exists path) then (
437 let msg = sprintf "directory '%s' required but not found" path in
440 let goal_file_newer_than f1 f2 =
441 if not (file_newer_than f1 f2) then (
442 let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
445 let goal_more_recent objs srcs =
446 if not (more_recent objs srcs) then (
447 let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
448 (String.concat " " objs) (String.concat " " srcs) in
451 let goal_url_exists url =
452 if not (url_exists url) then (
453 let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
456 let goal_file_contains_string filename str =
457 if not (file_contains_string filename str) then (
458 let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
461 let goal_url_contains_string url str =
462 if not (url_contains_string url str) then (
463 let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
466 let goal_memory_exists k =
467 if not (memory_exists k) then (
468 let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
475 | Goal_result (Goal_failed msg) ->
476 prerr_endline ("error: " ^ msg);
479 prerr_endline (Printexc.to_string exn);
482 (* Run the program. *)
484 let prog = Sys.executable_name in
485 let prog = Filename.basename prog in
487 (* Save the current working directory when the program started. *)
488 putenv "builddir" (getcwd ());
492 let display_version () =
493 printf "%s %s\n" package_name package_version;
498 let names = !published_goals in
499 let names = List.map fst names in
500 let names = List.sort compare names in
501 List.iter print_endline names;
505 let argspec = Arg.align [
506 "--goals", Arg.Unit list_goals, " List all goals";
507 "-l", Arg.Unit list_goals, " List all goals";
508 "-V", Arg.Unit display_version, " Display version number and exit";
509 "--version", Arg.Unit display_version, " Display version number and exit";
511 let anon_fun str = args := str :: !args in
512 let usage_msg = sprintf "\
513 %s: a script generated by goaljobs
515 List all goals: %s -l
516 Run a single goal like this: %s <name-of-goal> [<goal-args ...>]
518 For more information see the goaljobs(1) man page.
523 Arg.parse argspec anon_fun usage_msg;
525 let args = List.rev !args in
527 (* Was a goal named on the command line? *)
530 (match get_goal name with
532 exit (if guard fn args then 0 else 1)
534 eprintf "error: no goal called '%s' was found.\n" name;
535 eprintf "Use %s -l to list all published goals in this script.\n" name;
539 (* If periodic jobs exist, fall through. *)
540 if !periodic_jobs = [] then (
541 (* Does a published 'all' goal exist? *)
542 match get_goal "all" with
544 exit (if guard fn [] then 0 else 1)
546 (* No published 'all' goal. *)
547 eprintf "error: no goal called 'all' was found.\n";
552 assert (!periodic_jobs <> []);
554 (* Run the periodic jobs. Note these run forever, or until killed. *)
556 (* Find the next job to run. *)
558 let jobs = List.map (
559 fun (period, (_, _ as name_f)) ->
560 next_time now period, name_f
562 let jobs = List.sort (fun (t1,_) (t2,_) -> compare t1 t2) jobs in
564 (* Find all jobs that have the same next time.
565 * XXX When we can handle parallel jobs we can do better here,
566 * but until them run all the ones which have the same time
569 let next_t = int_of_float (fst (List.hd jobs)) in
570 let jobs = List.filter (fun (t, _) -> int_of_float t = next_t) jobs in
572 (* Run next job(s) after waiting for the appropriate amount of time. *)
573 let seconds = next_t - int_of_float now in
574 eprintf "next job will run in %s\n%!" (printable_seconds seconds);
578 fun (_, (name, f)) ->
579 eprintf "running job: %s\n%!"
580 (match name with Some name -> name | None -> "[unnamed]");
585 and printable_seconds s =
586 if s < 60 then sprintf "%d seconds" s
587 else if s < 6000 then sprintf "%d minutes, %d seconds" (s/60) (s mod 60)
588 else if s < 86400 then sprintf "%d hours, %d minutes" (s/3600) (s/60)
589 else sprintf "about %d days" (s/86400)