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

diff --git a/goaljobs.ml b/goaljobs.ml
index 282c29e..4024b6d 100644
--- a/goaljobs.ml
+++ b/goaljobs.ml
@@ -16,22 +16,165 @@
  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  *)
 
+open CalendarLib
+
 open Unix
 open Printf
 
+open Goaljobs_config
+
+type ('a, 'b) alternative = Either of 'a | Or of 'b
+
+let (//) = Filename.concat
+let quote = Filename.quote
+
 type goal_result_t = Goal_OK | Goal_failed of string
 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)
+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)
@@ -60,51 +203,137 @@ let more_recent objs srcs =
     ) objs
   )
 
-let url_exists url = goal_failed "url_exists not implemented!"
+let url_exists url =
+  (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
+  let cmd =
+    sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
+  match Sys.command cmd with
+  | 0 -> true
+  | 19|22 -> false
+  | r ->
+    let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
+      url r in
+    goal_failed msg
 
-let sh fs =
-  let do_sh cmd =
-    let cmd = "set -e\nset -x\n\n" ^ cmd in
-    let r = Sys.command cmd in
-    if r <> 0 then (
-      let msg = sprintf "external command failed with code %d" r in
-      goal_failed msg
+let file_contains_string filename str =
+  let cmd = sprintf "grep -q -F %s %s" (quote str) (quote filename) in
+  match Sys.command cmd with
+  | 0 -> true
+  | 1 -> false
+  | r ->
+    let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
+      str filename r in
+    goal_failed msg
+
+let url_contains_string url str =
+  let tmp = Filename.temp_file "goaljobsurl" "" in
+  let cmd =
+    sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
+  (match Sys.command cmd with
+  | 0 -> ()
+  | 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, see curl(1)"
+      url r in
+    goal_failed msg
+  );
+  let r = file_contains_string tmp str in
+  unlink tmp;
+  r
+
+(* Create a temporary directory.  It is *not* deleted on exit. *)
+let make_tmpdir () =
+  let chan = open_in "/dev/urandom" in
+  let data = String.create 16 in
+  really_input chan data 0 (String.length data);
+  close_in chan;
+  let data = Digest.to_hex (Digest.string data) in
+  let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
+  mkdir dir 0o700;
+  dir
+
+(* Recursively remove directory. *)
+let rm_rf dir =
+  let cmd = sprintf "rm -rf %s" (quote dir) in
+  ignore (Sys.command cmd)
+
+let shell = ref "/bin/sh"
+
+(* 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;
+  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 ?tmpdir fs =
+  let do_sh script =
+    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 cmd =
-  let cmd = "set -e\nset -x\n\n" ^ cmd 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
-  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 cmd =
-  let lines = do_shlines cmd in
+let do_shout ?tmpdir script =
+  let lines = do_shlines ?tmpdir script in
   String.concat "\n" lines
-let shout fs = ksprintf do_shout fs
-
-(*
-val shell : string ref
-*)
+let shout ?tmpdir fs = ksprintf (do_shout ?tmpdir) fs
 
 (*
 val replace_substring : string -> string -> string -> string
@@ -120,19 +349,114 @@ let change_file_extension ext filename =
 val filter_file_extension : string -> string list -> string
 *)
 
-(* XXX The Memory is not actually persistent yet. *)
-let memory = Hashtbl.create 13
+(* Persistent memory is stored in $HOME/.goaljobs-memory.  We have to
+ * lock this file each time we read or write because multiple concurrent
+ * jobs may access it at the same time.
+ *
+ * XXX Replace this with a more efficient and less fragile implementation.
+ *)
+
+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 memory_exists = Hashtbl.mem memory
-let memory_set = Hashtbl.replace memory
-let memory_get k = try Some (Hashtbl.find memory k) with Not_found -> None
-let memory_delete = Hashtbl.remove memory
+  (* 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
+
+let memory_exists key =
+  with_memory_locked (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      Hashtbl.mem memory key
+  )
+
+let memory_get key =
+  with_memory_locked (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      try Some (Hashtbl.find memory key) with Not_found -> None
+  )
+
+let memory_set key value =
+  with_memory_locked ~write:true (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      Hashtbl.replace memory key value;
+      let chan = out_channel_of_descr fd in
+      seek_out chan 0;
+      output_value chan memory;
+      Pervasives.flush chan;
+  )
+
+let memory_delete key =
+  with_memory_locked ~write:true (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      Hashtbl.remove memory key;
+      let chan = out_channel_of_descr fd in
+      seek_out chan 0;
+      output_value chan memory;
+      Pervasives.flush chan;
+  )
+
+let published_goals = ref []
+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
     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
@@ -149,8 +473,137 @@ let goal_url_exists url =
     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
     goal_failed msg
   )
+let goal_file_contains_string filename str =
+  if not (file_contains_string filename str) then (
+    let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
+    goal_failed msg
+  )
+let goal_url_contains_string url str =
+  if not (url_contains_string url str) then (
+    let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
+    goal_failed msg
+  )
 let goal_memory_exists k =
   if not (memory_exists k) then (
     let msg = sprintf "memory_exists: key '%s' required but does not exist" k 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 rec init () =
+  let prog = Sys.executable_name in
+  let prog = Filename.basename prog in
+
+  (* Save the current working directory when the program started. *)
+  putenv "builddir" (getcwd ());
+
+  let args = ref [] in
+
+  let display_version () =
+    printf "%s %s\n" package_name package_version;
+    exit 0
+  in
+
+  let list_goals () =
+    let names = !published_goals in
+    let names = List.map fst names in
+    let names = List.sort compare names in
+    List.iter print_endline names;
+    exit 0
+  in
+
+  let argspec = Arg.align [
+    "--goals", Arg.Unit list_goals, " List all goals";
+    "-l", Arg.Unit list_goals, " List all goals";
+    "-V", Arg.Unit display_version, " Display version number and exit";
+    "--version", Arg.Unit display_version, " Display version number and exit";
+  ] in
+  let anon_fun str = args := str :: !args in
+  let usage_msg = sprintf "\
+%s: a script generated by goaljobs
+
+List all goals:                %s -l
+Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
+
+For more information see the goaljobs(1) man page.
+
+Options:
+" prog prog prog in
+
+  Arg.parse argspec anon_fun usage_msg;
+
+  let args = List.rev !args in
+
+  (* Was a goal named on the command line? *)
+  (match args with
+  | name :: args ->
+    (match get_goal name with
+    | 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;
+      exit 1
+    )
+  | [] ->
+    (* 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 jobs = List.map (
+      fun (period, (_, _ as name_f)) ->
+        next_time now period, name_f
+    ) !periodic_jobs in
+    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;
+
+    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 =
+  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)