open Goaljobs_config
+type ('a, 'b) alternative = Either of 'a | Or of 'b
+
let (//) = Filename.concat
let quote = Filename.quote
let goal_failed msg = raise (Goal_result (Goal_failed msg))
+let depth = ref 0
+let indent fs =
+ let do_indent str =
+ prerr_string "| ";
+ for i = 0 to !depth-1 do prerr_string " " done;
+ prerr_string str;
+ Pervasives.flush Pervasives.stderr
+ in
+ ksprintf do_indent fs
+
let target v =
if v then raise (Goal_result Goal_OK)
let target_all vs = target (List.fold_left (&&) true vs)
let target_exists vs = target (List.fold_left (||) false vs)
-let require () = ()
+let require name f =
+ indent "require: %s\n" name;
+ incr depth;
+ let r = (try Either (f ()) with exn -> Or exn) in
+ decr depth;
+ match r with
+ | Either x -> x
+ | Or exn -> raise exn
+
+let _enter_goal name = indent "enter goal: %s\n" name
+let _leave_goal name = indent "leave goal: %s\n" name
type period_t = Seconds | Days | Months | Years
let seconds = (1, Seconds)
(* 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
+ periodic_jobs := (period, (name, f)) :: !periodic_jobs
(* [next_time t period] returns the earliest event of [period]
strictly after time [t].
sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
match Sys.command cmd with
| 0 -> true
- | 1 -> false
+ | 19|22 -> false
| r ->
- let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
+ let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
+ url r in
goal_failed msg
let file_contains_string filename str =
- let cmd = sprintf "grep -q %s %s" (quote str) (quote filename) in
+ let cmd = sprintf "grep -q -F %s %s" (quote str) (quote filename) in
match Sys.command cmd with
| 0 -> true
| 1 -> false
sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
(match Sys.command cmd with
| 0 -> ()
- | 1 ->
+ | 19|22 ->
let msg = sprintf "curl failed to download URL '%s'" url in
goal_failed msg
| r ->
- let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
+ let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
+ url r in
goal_failed msg
);
let r = file_contains_string tmp str in
r
(* Create a temporary directory. It is *not* deleted on exit. *)
-let tmpdir () =
+let make_tmpdir () =
let chan = open_in "/dev/urandom" in
let data = String.create 16 in
really_input chan data 0 (String.length data);
let shell = ref "/bin/sh"
-(* Used by sh, shout etc. Create a temporary directory and a
- * 'script.sh' inside it containing the script to run. Returns the
- * temporary directory and command to run.
- *)
-let create_script script =
- let dir = tmpdir () in
- let script_file = dir // "script.sh" in
- let chan = open_out script_file in
+(* Used by sh, shout, shlines to handle the script and temporary dir. *)
+let with_script ?(tmpdir = true) script f =
+ let dir = if tmpdir then Some (make_tmpdir ()) else None in
+ let script_file, chan =
+ match dir with
+ | Some dir ->
+ let script_file = dir // "script.sh" in
+ let chan = open_out script_file in
+ script_file, chan
+ | None -> Filename.open_temp_file "goaljobsscript" ".sh" in
+ chmod script_file 0o700;
fprintf chan "#!%s\n" !shell;
fprintf chan "set -e\n"; (* so that job exits on error *)
fprintf chan "set -x\n"; (* echo commands (must be last) *)
fprintf chan "\n";
output_string chan script;
close_out chan;
- chmod script_file 0o700;
- let cmd = sprintf "cd %s && exec %s" (quote dir) (quote script_file) in
- dir, cmd
+ let cmd =
+ match dir with
+ | Some dir -> sprintf "cd %s && exec %s" (quote dir) (quote script_file)
+ | None -> sprintf "exec %s" (quote script_file) in
+ let r = try Either (f cmd) with exn -> Or exn in
+ (match dir with
+ | Some dir -> rm_rf dir
+ | None -> ()
+ );
+ match r with
+ | Either x -> x
+ | Or exn -> raise exn
-let sh fs =
+let sh ?tmpdir fs =
let do_sh script =
- let dir, cmd = create_script script in
- let r = Sys.command cmd in
- rm_rf dir;
- if r <> 0 then (
- let msg = sprintf "external command failed with code %d" r in
- goal_failed msg
+ with_script ?tmpdir script (
+ fun cmd ->
+ let r = Sys.command cmd in
+ if r <> 0 then (
+ let msg = sprintf "external command failed with code %d" r in
+ goal_failed msg
+ )
)
in
ksprintf do_sh fs
-let do_shlines script =
- let dir, cmd = create_script script in
- let chan = open_process_in cmd in
- let lines = ref [] in
- let rec loop () =
- let line = input_line chan in
- lines := line :: !lines;
- loop ()
- in
- (try loop () with End_of_file -> ());
- let r = close_process_in chan in
- rm_rf dir;
- match r with
- | WEXITED 0 -> List.rev !lines
- | WEXITED i ->
- let msg = sprintf "external command failed with code %d" i in
- goal_failed msg
- | WSIGNALED i ->
- let msg = sprintf "external command was killed by signal %d" i in
- goal_failed msg
- | WSTOPPED i ->
- let msg = sprintf "external command was stopped by signal %d" i in
- goal_failed msg
-let shlines fs = ksprintf do_shlines fs
+let do_shlines ?tmpdir script =
+ with_script ?tmpdir script (
+ fun cmd ->
+ let chan = open_process_in cmd in
+ let lines = ref [] in
+ let rec loop () =
+ let line = input_line chan in
+ eprintf "%s\n%!" line;
+ lines := line :: !lines;
+ loop ()
+ in
+ (try loop () with End_of_file -> ());
+ match close_process_in chan with
+ | WEXITED 0 -> List.rev !lines
+ | WEXITED i ->
+ let msg = sprintf "external command failed with code %d" i in
+ goal_failed msg
+ | WSIGNALED i ->
+ let msg = sprintf "external command was killed by signal %d" i in
+ goal_failed msg
+ | WSTOPPED i ->
+ let msg = sprintf "external command was stopped by signal %d" i in
+ goal_failed msg
+ )
+let shlines ?tmpdir fs = ksprintf (do_shlines ?tmpdir) fs
-let do_shout script =
- let lines = do_shlines script in
+let do_shout ?tmpdir script =
+ let lines = do_shlines ?tmpdir script in
String.concat "\n" lines
-let shout fs = ksprintf do_shout fs
+let shout ?tmpdir fs = ksprintf (do_shout ?tmpdir) fs
(*
val replace_substring : string -> string -> string -> string
* XXX Replace this with a more efficient and less fragile implementation.
*)
-type ('a, 'b) alternative = Either of 'a | Or of 'b
let with_memory_locked ?(write = false) f =
let filename = getenv "HOME" // ".goaljobs-memory" in
let fd = openfile filename [O_RDWR; O_CREAT] 0o644 in
lockf fd (if write then F_LOCK else F_RLOCK) 0;
- let r = try Either (f fd) with exn -> Or (exn) in
+
+ (* If the file is newly created with zero size, write an
+ * empty hash table.
+ *)
+ if (fstat fd).st_size = 0 then (
+ let empty : (string, string) Hashtbl.t = Hashtbl.create 13 in
+ let chan = out_channel_of_descr fd in
+ output_value chan empty;
+ Pervasives.flush chan;
+ ignore (lseek fd 0 SEEK_SET)
+ );
+
+ (* Run the function. *)
+ let r = try Either (f fd) with exn -> Or exn in
lockf fd F_ULOCK 0;
+ close fd;
match r with
| Either x -> x
| Or exn -> raise exn
Hashtbl.replace memory key value;
let chan = out_channel_of_descr fd in
seek_out chan 0;
- output_value chan memory
+ output_value chan memory;
+ Pervasives.flush chan;
)
let memory_delete key =
Hashtbl.remove memory key;
let chan = out_channel_of_descr fd in
seek_out chan 0;
- output_value chan memory
+ output_value chan memory;
+ Pervasives.flush chan;
)
let published_goals = ref []
let get_goal name =
try Some (List.assoc name !published_goals) with Not_found -> None
+let log_program_output () =
+ let filename = Filename.temp_file "goaljobslog" ".txt" in
+ let cmd = "tee " ^ quote filename in
+ let chan = open_process_out cmd in
+ let fd = descr_of_out_channel chan in
+ dup2 fd stdout;
+ dup2 fd stderr;
+ filename
+
+let mailto ?from ~subject ?(attach = []) to_ =
+ let cmd = ref (sprintf "%s -s %s" mailx (quote subject)) in
+ (match from with
+ | None -> ()
+ | Some f -> cmd := !cmd ^ " -r " ^ quote f
+ );
+ List.iter (
+ fun a -> cmd := !cmd ^ " -a " ^ quote a
+ ) attach;
+ cmd := !cmd ^ " " ^ quote to_;
+ if Sys.command !cmd <> 0 then
+ goal_failed "mailto: could not send email"
+
let goal_file_exists filename =
if not (file_exists filename) then (
let msg = sprintf "file '%s' required but not found" filename in
goal_failed msg
)
+let goal_directory_exists path =
+ if not (directory_exists path) then (
+ let msg = sprintf "directory '%s' required but not found" path in
+ goal_failed msg
+ )
let goal_file_newer_than f1 f2 =
if not (file_newer_than f1 f2) then (
let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
goal_failed msg
)
+let guard fn arg =
+ try fn arg; true
+ with
+ | Goal_result (Goal_failed msg) ->
+ prerr_endline ("error: " ^ msg);
+ false
+ | exn ->
+ prerr_endline (Printexc.to_string exn);
+ false
+
(* Run the program. *)
-let init () =
+let rec init () =
let prog = Sys.executable_name in
let prog = Filename.basename prog in
let args = List.rev !args in
(* Was a goal named on the command line? *)
- match args with
+ (match args with
| name :: args ->
(match get_goal name with
- | Some fn -> fn args
+ | Some fn ->
+ exit (if guard fn args then 0 else 1)
| None ->
eprintf "error: no goal called '%s' was found.\n" name;
eprintf "Use %s -l to list all published goals in this script.\n" name;
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
+ let jobs = List.map (
+ fun (period, (_, _ as 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);
+ let jobs = List.sort (fun (t1,_) (t2,_) -> compare t1 t2) jobs in
+
+ (* Find all jobs that have the same next time.
+ * XXX When we can handle parallel jobs we can do better here,
+ * but until them run all the ones which have the same time
+ * in series.
+ *)
+ let next_t = int_of_float (fst (List.hd jobs)) in
+ let jobs = List.filter (fun (t, _) -> int_of_float t = next_t) jobs in
+
+ (* Run next job(s) after waiting for the appropriate amount of time. *)
+ let seconds = next_t - int_of_float now in
+ eprintf "next job will run in %s\n%!" (printable_seconds seconds);
sleep seconds;
- ignore (guard f ())
+
+ List.iter (
+ fun (_, (name, f)) ->
+ eprintf "running job: %s\n%!"
+ (match name with Some name -> name | None -> "[unnamed]");
+ ignore (guard f ())
+ ) jobs
done
and printable_seconds s =
git.annexia.org / goaljobs.git / blobdiff