X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=goaljobs.ml;h=4024b6da999770be1dc4c56fcc60853c95e2f541;hb=bd08c0a87a906c312deeed28f55bd94e76fecac7;hp=4a66780c19ac5b226ac1582daf1ee487c2e76215;hpb=fe7c2d759549772a2c58f7941d17effca65fcc83;p=goaljobs.git

diff --git a/goaljobs.ml b/goaljobs.ml
index 4a66780..4024b6d 100644
--- a/goaljobs.ml
+++ b/goaljobs.ml
@@ -23,6 +23,8 @@ open Printf
 
 open Goaljobs_config
 
+type ('a, 'b) alternative = Either of 'a | Or of 'b
+
 let (//) = Filename.concat
 let quote = Filename.quote
 
@@ -31,11 +33,31 @@ exception Goal_result of goal_result_t
 
 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)
@@ -58,7 +80,7 @@ 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
+  periodic_jobs := (period, (name, f)) :: !periodic_jobs
 
 (* [next_time t period] returns the earliest event of [period]
    strictly after time [t].
@@ -187,13 +209,14 @@ let url_exists url =
     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
@@ -208,11 +231,12 @@ let url_contains_string url str =
     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
@@ -220,7 +244,7 @@ let url_contains_string url str =
   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);
@@ -237,65 +261,79 @@ let rm_rf dir =
 
 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
@@ -318,11 +356,11 @@ val filter_file_extension : string -> string list -> 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;
+
   (* If the file is newly created with zero size, write an
    * empty hash table.
    *)
@@ -335,8 +373,9 @@ let with_memory_locked ?(write = false) f =
   );
 
   (* Run the function. *)
-  let r = try Either (f fd) with exn -> Or (exn) in
+  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
@@ -386,6 +425,28 @@ let publish name fn = published_goals := (name, fn) :: !published_goals
 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
@@ -514,20 +575,31 @@ Options:
   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 =