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 let (//) = Filename.concat
27 let quote = Filename.quote
29 type goal_result_t = Goal_OK | Goal_failed of string
30 exception Goal_result of goal_result_t
32 let goal_failed msg = raise (Goal_result (Goal_failed msg))
35 if v then raise (Goal_result Goal_OK)
36 let target_all vs = target (List.fold_left (&&) true vs)
37 let target_exists vs = target (List.fold_left (||) false vs)
40 type period_t = Seconds | Days | Months | Years
41 let seconds = (1, Seconds)
42 let sec = seconds and secs = seconds and second = seconds
43 let minutes = (60, Seconds)
44 let min = minutes and mins = minutes and minute = minutes
45 let hours = (3600, Seconds)
51 let months = (1, Months)
53 let years = (1, Years)
56 let periodic_jobs = ref []
58 (* Register a periodic job. *)
59 let every ?name i (j, t) f =
60 let period = i*j, t in (* 5 minutes -> ((5 * 60), Seconds) *)
61 periodic_jobs := (period, name, f) :: !periodic_jobs
63 (* [next_time t period] returns the earliest event of [period]
64 strictly after time [t].
66 Visualising periods as repeated events on a timeline, this
70 events: ---+---------+---------+---------+---------+---------+-----
74 Note that [period_t] events are not necessarily regular.
75 eg. The start of a month is not a fixed number of seconds
76 after the start of the previous month. 'Epoch' refers
77 to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
79 If [period = i, Seconds i] then events are when
80 [t' mod i == 0] when t' is the number of seconds since
81 the Epoch. This returns the next t' > t.
83 If [period = i, Days] then events happen at
84 midnight UTC every [i] days since the Epoch.
85 This returns the next midnight > t.
87 If [period = i, Months] then events happen at
88 midnight UTC on the 1st day of the month every [i] months
89 since the Epoch. This returns midnight on the
90 1st day of the next month > t.
92 If [period = i, Years] then events happen at
93 midnight UTC on the 1st day of the year when
94 [(y - 1970) mod i == 0]. This returns midnight on the
95 1st day of the next year > t. *)
98 (* Round up 'a' to the next multiple of 'i'. *)
99 let round_up_float a i =
100 let r = mod_float a i in
101 if r = 0. then a +. i else a +. (i -. r)
104 if r = 0 then a + i else a + (i - r)
109 let i = float_of_int i in
115 (* Round 'tm' up to the first day of the next year. *)
116 let year = round_up tm.tm_year i in
117 let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
118 tm_mday = 1; tm_mon = 0; tm_year = year } in
122 let t = Date.from_unixfloat t in
123 let t0 = Date.make 1970 1 1 in
125 (* Number of whole days since Unix Epoch. *)
126 let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
128 let nb_days = round_up nb_days i in
129 let t' = Date.add t0 (Date.Period.day nb_days) in
133 (* Calculate number of whole months since Unix Epoch. *)
135 let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
137 let months = round_up months i in
138 let t0 = Date.make 1970 1 1 in
139 let t' = Date.add t0 (Date.Period.month months) in
142 let file_exists = Sys.file_exists
144 let directory_exists path =
148 | Unix_error (ENOENT, _, _) -> None
149 | Unix_error (err, _, _) ->
150 let msg = sprintf "directory_exists: %s: %s" path (error_message err) in
153 | Some s -> s.st_kind = S_DIR
156 let file_newer_than f1 f2 =
160 | Unix_error (ENOENT, _, _) -> None
161 | Unix_error (err, _, _) ->
162 let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
165 let s1 = stat f1 and s2 = stat f2 in
171 let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
174 s1.st_mtime >= s2.st_mtime
176 let more_recent objs srcs =
177 if not (List.for_all file_exists objs) then false
180 fun obj -> List.for_all (file_newer_than obj) srcs
185 (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
187 sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
188 match Sys.command cmd with
192 let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
195 let file_contains_string filename str =
196 let cmd = sprintf "grep -q %s %s" (quote str) (quote filename) in
197 match Sys.command cmd with
201 let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
205 let url_contains_string url str =
206 let tmp = Filename.temp_file "goaljobsurl" "" in
208 sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
209 (match Sys.command cmd with
212 let msg = sprintf "curl failed to download URL '%s'" url in
215 let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
218 let r = file_contains_string tmp str in
222 (* Create a temporary directory. It is *not* deleted on exit. *)
224 let chan = open_in "/dev/urandom" in
225 let data = String.create 16 in
226 really_input chan data 0 (String.length data);
228 let data = Digest.to_hex (Digest.string data) in
229 let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
233 (* Recursively remove directory. *)
235 let cmd = sprintf "rm -rf %s" (quote dir) in
236 ignore (Sys.command cmd)
238 let shell = ref "/bin/sh"
240 (* Used by sh, shout etc. Create a temporary directory and a
241 * 'script.sh' inside it containing the script to run. Returns the
242 * temporary directory and command to run.
244 let create_script script =
245 let dir = tmpdir () in
246 let script_file = dir // "script.sh" in
247 let chan = open_out script_file in
248 fprintf chan "#!%s\n" !shell;
249 fprintf chan "set -e\n"; (* so that job exits on error *)
250 fprintf chan "set -x\n"; (* echo commands (must be last) *)
252 output_string chan script;
254 chmod script_file 0o700;
255 let cmd = sprintf "cd %s && exec %s" (quote dir) (quote script_file) in
260 let dir, cmd = create_script script in
261 let r = Sys.command cmd in
264 let msg = sprintf "external command failed with code %d" r in
270 let do_shlines script =
271 let dir, cmd = create_script script in
272 let chan = open_process_in cmd in
273 let lines = ref [] in
275 let line = input_line chan in
276 lines := line :: !lines;
279 (try loop () with End_of_file -> ());
280 let r = close_process_in chan in
283 | WEXITED 0 -> List.rev !lines
285 let msg = sprintf "external command failed with code %d" i in
288 let msg = sprintf "external command was killed by signal %d" i in
291 let msg = sprintf "external command was stopped by signal %d" i in
293 let shlines fs = ksprintf do_shlines fs
295 let do_shout script =
296 let lines = do_shlines script in
297 String.concat "\n" lines
298 let shout fs = ksprintf do_shout fs
301 val replace_substring : string -> string -> string -> string
304 let change_file_extension ext filename =
306 try String.rindex filename '.'
307 with Not_found -> String.length filename in
308 String.sub filename 0 i ^ "." ^ ext
311 val filter_file_extension : string -> string list -> string
314 (* Persistent memory is stored in $HOME/.goaljobs-memory. We have to
315 * lock this file each time we read or write because multiple concurrent
316 * jobs may access it at the same time.
318 * XXX Replace this with a more efficient and less fragile implementation.
321 type ('a, 'b) alternative = Either of 'a | Or of 'b
322 let with_memory_locked ?(write = false) f =
323 let filename = getenv "HOME" // ".goaljobs-memory" in
324 let fd = openfile filename [O_RDWR; O_CREAT] 0o644 in
325 lockf fd (if write then F_LOCK else F_RLOCK) 0;
326 let r = try Either (f fd) with exn -> Or (exn) in
330 | Or exn -> raise exn
332 let memory_exists key =
335 let chan = in_channel_of_descr fd in
336 let memory : (string, string) Hashtbl.t = input_value chan in
337 Hashtbl.mem memory key
343 let chan = in_channel_of_descr fd in
344 let memory : (string, string) Hashtbl.t = input_value chan in
345 try Some (Hashtbl.find memory key) with Not_found -> None
348 let memory_set key value =
349 with_memory_locked ~write:true (
351 let chan = in_channel_of_descr fd in
352 let memory : (string, string) Hashtbl.t = input_value chan in
353 Hashtbl.replace memory key value;
354 let chan = out_channel_of_descr fd in
356 output_value chan memory
359 let memory_delete key =
360 with_memory_locked ~write:true (
362 let chan = in_channel_of_descr fd in
363 let memory : (string, string) Hashtbl.t = input_value chan in
364 Hashtbl.remove memory key;
365 let chan = out_channel_of_descr fd in
367 output_value chan memory
370 let published_goals = ref []
371 let publish name fn = published_goals := (name, fn) :: !published_goals
373 try Some (List.assoc name !published_goals) with Not_found -> None
375 let goal_file_exists filename =
376 if not (file_exists filename) then (
377 let msg = sprintf "file '%s' required but not found" filename in
380 let goal_file_newer_than f1 f2 =
381 if not (file_newer_than f1 f2) then (
382 let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
385 let goal_more_recent objs srcs =
386 if not (more_recent objs srcs) then (
387 let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
388 (String.concat " " objs) (String.concat " " srcs) in
391 let goal_url_exists url =
392 if not (url_exists url) then (
393 let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
396 let goal_file_contains_string filename str =
397 if not (file_contains_string filename str) then (
398 let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
401 let goal_url_contains_string url str =
402 if not (url_contains_string url str) then (
403 let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
406 let goal_memory_exists k =
407 if not (memory_exists k) then (
408 let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
412 (* Run the program. *)
414 let prog = Sys.executable_name in
415 let prog = Filename.basename prog in
417 (* Save the current working directory when the program started. *)
418 putenv "builddir" (getcwd ());
422 let display_version () =
423 printf "%s %s\n" package_name package_version;
428 let names = !published_goals in
429 let names = List.map fst names in
430 let names = List.sort compare names in
431 List.iter print_endline names;
435 let argspec = Arg.align [
436 "--goals", Arg.Unit list_goals, " List all goals";
437 "-l", Arg.Unit list_goals, " List all goals";
438 "-V", Arg.Unit display_version, " Display version number and exit";
439 "--version", Arg.Unit display_version, " Display version number and exit";
441 let anon_fun str = args := str :: !args in
442 let usage_msg = sprintf "\
443 %s: a script generated by goaljobs
445 List all goals: %s -l
446 Run a single goal like this: %s <name-of-goal> [<goal-args ...>]
448 For more information see the goaljobs(1) man page.
453 Arg.parse argspec anon_fun usage_msg;
455 let args = List.rev !args in
457 (* Was a goal named on the command line? *)
460 (match get_goal name with
463 eprintf "error: no goal called '%s' was found.\n" name;
464 eprintf "Use %s -l to list all published goals in this script.\n" name;
468 (* If periodic jobs exist, fall through. *)
469 if !periodic_jobs = [] then (
470 (* Does a published 'all' goal exist? *)
471 match get_goal "all" with
473 exit (if guard fn [] then 0 else 1)
475 (* No published 'all' goal. *)
476 eprintf "error: no goal called 'all' was found.\n";
481 assert (!periodic_jobs <> []);
483 (* Run the periodic jobs. Note these run forever, or until killed. *)
485 (* Find the next job to run. *)
487 let next = List.map (
488 fun (period, name, f) ->
489 next_time now period, name, f
491 let next = List.sort (fun (t1,_,_) (t2,_,_) -> compare t1 t2) next in
492 let next_t, name, f = List.hd next in
494 let name = match name with Some name -> name | None -> "[unnamed]" in
496 (* Run it after waiting for the appropriate amount of time. *)
497 let seconds = int_of_float (next_t -. now) in
498 eprintf "next job '%s' will run in %s\n%!" name (printable_seconds seconds);
503 and printable_seconds s =
504 if s < 60 then sprintf "%d seconds" s
505 else if s < 6000 then sprintf "%d minutes, %d seconds" (s/60) (s mod 60)
506 else if s < 86400 then sprintf "%d hours, %d minutes" (s/3600) (s/60)
507 else sprintf "about %d days" (s/86400)