Pass a suspension to 'require'.
[goaljobs.git] / goaljobs.ml
1 (* goaljobs
2  * Copyright (C) 2013 Red Hat Inc.
3  *
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.
8  *
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.
13  *
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.
17  *)
18
19 open CalendarLib
20
21 open Unix
22 open Printf
23
24 open Goaljobs_config
25
26 let (//) = Filename.concat
27 let quote = Filename.quote
28
29 type goal_result_t = Goal_OK | Goal_failed of string
30 exception Goal_result of goal_result_t
31
32 let goal_failed msg = raise (Goal_result (Goal_failed msg))
33
34 let target v =
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)
38 let require f = f ()
39
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)
46 let hour = hours
47 let days = (1, Days)
48 let day = days
49 let weeks = (7, Days)
50 let week = weeks
51 let months = (1, Months)
52 let month = months
53 let years = (1, Years)
54 let year = years
55
56 let periodic_jobs = ref []
57
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
62
63 (* [next_time t period] returns the earliest event of [period]
64    strictly after time [t].
65
66    Visualising periods as repeated events on a timeline, this
67    returns [t']:
68
69    {v
70    events:  ---+---------+---------+---------+---------+---------+-----
71    times:          t     t'
72    }
73
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).
78
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.
82
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.
86
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.
91
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. *)
96
97 let next_time =
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)
102   and round_up a i =
103     let r = a mod i in
104     if r = 0 then a + i else a + (i - r)
105   in
106
107   fun t -> function
108   | (i, Seconds) ->
109     let i = float_of_int i in
110     round_up_float t i
111
112   | (i, Years) ->
113     let tm = gmtime t in
114
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
119     fst (mktime tm)
120
121   | (i, Days) ->
122     let t = Date.from_unixfloat t in
123     let t0 = Date.make 1970 1 1 in
124
125     (* Number of whole days since Unix Epoch. *)
126     let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
127
128     let nb_days = round_up nb_days i in
129     let t' = Date.add t0 (Date.Period.day nb_days) in
130     Date.to_unixfloat t'
131
132   | (i, Months) ->
133     (* Calculate number of whole months since Unix Epoch. *)
134     let tm = gmtime t in
135     let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
136
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
140     Date.to_unixfloat t'
141
142 let file_exists = Sys.file_exists
143
144 let directory_exists path =
145   let s =
146     try Some (stat path)
147     with
148     | Unix_error (ENOENT, _, _) -> None
149     | Unix_error (err, _, _) ->
150       let msg = sprintf "directory_exists: %s: %s" path (error_message err) in
151       goal_failed msg in
152   match s with
153   | Some s -> s.st_kind = S_DIR
154   | None -> false
155
156 let file_newer_than f1 f2 =
157   let stat f =
158     try Some (stat f)
159     with
160     | Unix_error (ENOENT, _, _) -> None
161     | Unix_error (err, _, _) ->
162       let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
163       goal_failed msg
164   in
165   let s1 = stat f1 and s2 = stat f2 in
166   match s1 with
167   | None -> false
168   | Some s1 ->
169     match s2 with
170     | None ->
171       let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
172       goal_failed msg
173     | Some s2 ->
174       s1.st_mtime >= s2.st_mtime
175
176 let more_recent objs srcs =
177   if not (List.for_all file_exists objs) then false
178   else (
179     List.for_all (
180       fun obj -> List.for_all (file_newer_than obj) srcs
181     ) objs
182   )
183
184 let url_exists url =
185   (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
186   let cmd =
187     sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
188   match Sys.command cmd with
189   | 0 -> true
190   | 19|22 -> false
191   | r ->
192     let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
193       url r in
194     goal_failed msg
195
196 let file_contains_string filename str =
197   let cmd = sprintf "grep -q %s %s" (quote str) (quote filename) in
198   match Sys.command cmd with
199   | 0 -> true
200   | 1 -> false
201   | r ->
202     let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
203       str filename r in
204     goal_failed msg
205
206 let url_contains_string url str =
207   let tmp = Filename.temp_file "goaljobsurl" "" in
208   let cmd =
209     sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
210   (match Sys.command cmd with
211   | 0 -> ()
212   | 19|22 ->
213     let msg = sprintf "curl failed to download URL '%s'" url in
214     goal_failed msg
215   | r ->
216     let msg = sprintf "curl error testing '%s': exit code %d, see curl(1)"
217       url r in
218     goal_failed msg
219   );
220   let r = file_contains_string tmp str in
221   unlink tmp;
222   r
223
224 (* Create a temporary directory.  It is *not* deleted on exit. *)
225 let tmpdir () =
226   let chan = open_in "/dev/urandom" in
227   let data = String.create 16 in
228   really_input chan data 0 (String.length data);
229   close_in chan;
230   let data = Digest.to_hex (Digest.string data) in
231   let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
232   mkdir dir 0o700;
233   dir
234
235 (* Recursively remove directory. *)
236 let rm_rf dir =
237   let cmd = sprintf "rm -rf %s" (quote dir) in
238   ignore (Sys.command cmd)
239
240 let shell = ref "/bin/sh"
241
242 (* Used by sh, shout etc.  Create a temporary directory and a
243  * 'script.sh' inside it containing the script to run.  Returns the
244  * temporary directory and command to run.
245  *)
246 let create_script script =
247   let dir = tmpdir () in
248   let script_file = dir // "script.sh" in
249   let chan = open_out script_file in
250   fprintf chan "#!%s\n" !shell;
251   fprintf chan "set -e\n"; (* so that job exits on error *)
252   fprintf chan "set -x\n"; (* echo commands (must be last) *)
253   fprintf chan "\n";
254   output_string chan script;
255   close_out chan;
256   chmod script_file 0o700;
257   let cmd = sprintf "cd %s && exec %s" (quote dir) (quote script_file) in
258   dir, cmd
259
260 let sh fs =
261   let do_sh script =
262     let dir, cmd = create_script script in
263     let r = Sys.command cmd in
264     rm_rf dir;
265     if r <> 0 then (
266       let msg = sprintf "external command failed with code %d" r in
267       goal_failed msg
268     )
269   in
270   ksprintf do_sh fs
271
272 let do_shlines script =
273   let dir, cmd = create_script script in
274   let chan = open_process_in cmd in
275   let lines = ref [] in
276   let rec loop () =
277     let line = input_line chan in
278     lines := line :: !lines;
279     loop ()
280   in
281   (try loop () with End_of_file -> ());
282   let r = close_process_in chan in
283   rm_rf dir;
284   match r with
285   | WEXITED 0 -> List.rev !lines
286   | WEXITED i ->
287     let msg = sprintf "external command failed with code %d" i in
288     goal_failed msg
289   | WSIGNALED i ->
290     let msg = sprintf "external command was killed by signal %d" i in
291     goal_failed msg
292   | WSTOPPED i ->
293     let msg = sprintf "external command was stopped by signal %d" i in
294     goal_failed msg
295 let shlines fs = ksprintf do_shlines fs
296
297 let do_shout script =
298   let lines = do_shlines script in
299   String.concat "\n" lines
300 let shout fs = ksprintf do_shout fs
301
302 (*
303 val replace_substring : string -> string -> string -> string
304 *)
305
306 let change_file_extension ext filename =
307   let i =
308     try String.rindex filename '.'
309     with Not_found -> String.length filename in
310   String.sub filename 0 i ^ "." ^ ext
311
312 (*
313 val filter_file_extension : string -> string list -> string
314 *)
315
316 (* Persistent memory is stored in $HOME/.goaljobs-memory.  We have to
317  * lock this file each time we read or write because multiple concurrent
318  * jobs may access it at the same time.
319  *
320  * XXX Replace this with a more efficient and less fragile implementation.
321  *)
322
323 type ('a, 'b) alternative = Either of 'a | Or of 'b
324 let with_memory_locked ?(write = false) f =
325   let filename = getenv "HOME" // ".goaljobs-memory" in
326   let fd = openfile filename [O_RDWR; O_CREAT] 0o644 in
327   lockf fd (if write then F_LOCK else F_RLOCK) 0;
328   (* If the file is newly created with zero size, write an
329    * empty hash table.
330    *)
331   if (fstat fd).st_size = 0 then (
332     let empty : (string, string) Hashtbl.t = Hashtbl.create 13 in
333     let chan = out_channel_of_descr fd in
334     output_value chan empty;
335     Pervasives.flush chan;
336     ignore (lseek fd 0 SEEK_SET)
337   );
338
339   (* Run the function. *)
340   let r = try Either (f fd) with exn -> Or (exn) in
341   lockf fd F_ULOCK 0;
342   match r with
343   | Either x -> x
344   | Or exn -> raise exn
345
346 let memory_exists key =
347   with_memory_locked (
348     fun fd ->
349       let chan = in_channel_of_descr fd in
350       let memory : (string, string) Hashtbl.t = input_value chan in
351       Hashtbl.mem memory key
352   )
353
354 let memory_get key =
355   with_memory_locked (
356     fun fd ->
357       let chan = in_channel_of_descr fd in
358       let memory : (string, string) Hashtbl.t = input_value chan in
359       try Some (Hashtbl.find memory key) with Not_found -> None
360   )
361
362 let memory_set key value =
363   with_memory_locked ~write:true (
364     fun fd ->
365       let chan = in_channel_of_descr fd in
366       let memory : (string, string) Hashtbl.t = input_value chan in
367       Hashtbl.replace memory key value;
368       let chan = out_channel_of_descr fd in
369       seek_out chan 0;
370       output_value chan memory;
371       Pervasives.flush chan;
372   )
373
374 let memory_delete key =
375   with_memory_locked ~write:true (
376     fun fd ->
377       let chan = in_channel_of_descr fd in
378       let memory : (string, string) Hashtbl.t = input_value chan in
379       Hashtbl.remove memory key;
380       let chan = out_channel_of_descr fd in
381       seek_out chan 0;
382       output_value chan memory;
383       Pervasives.flush chan;
384   )
385
386 let published_goals = ref []
387 let publish name fn = published_goals := (name, fn) :: !published_goals
388 let get_goal name =
389   try Some (List.assoc name !published_goals) with Not_found -> None
390
391 let goal_file_exists filename =
392   if not (file_exists filename) then (
393     let msg = sprintf "file '%s' required but not found" filename in
394     goal_failed msg
395   )
396 let goal_directory_exists path =
397   if not (directory_exists path) then (
398     let msg = sprintf "directory '%s' required but not found" path in
399     goal_failed msg
400   )
401 let goal_file_newer_than f1 f2 =
402   if not (file_newer_than f1 f2) then (
403     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
404     goal_failed msg
405   )
406 let goal_more_recent objs srcs =
407   if not (more_recent objs srcs) then (
408     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
409       (String.concat " " objs) (String.concat " " srcs) in
410     goal_failed msg
411   )
412 let goal_url_exists url =
413   if not (url_exists url) then (
414     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
415     goal_failed msg
416   )
417 let goal_file_contains_string filename str =
418   if not (file_contains_string filename str) then (
419     let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
420     goal_failed msg
421   )
422 let goal_url_contains_string url str =
423   if not (url_contains_string url str) then (
424     let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
425     goal_failed msg
426   )
427 let goal_memory_exists k =
428   if not (memory_exists k) then (
429     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
430     goal_failed msg
431   )
432
433 let guard fn arg =
434   try fn arg; true
435   with
436   | Goal_result (Goal_failed msg) ->
437     prerr_endline ("error: " ^ msg);
438     false
439   | exn ->
440     prerr_endline (Printexc.to_string exn);
441     false
442
443 (* Run the program. *)
444 let rec init () =
445   let prog = Sys.executable_name in
446   let prog = Filename.basename prog in
447
448   (* Save the current working directory when the program started. *)
449   putenv "builddir" (getcwd ());
450
451   let args = ref [] in
452
453   let display_version () =
454     printf "%s %s\n" package_name package_version;
455     exit 0
456   in
457
458   let list_goals () =
459     let names = !published_goals in
460     let names = List.map fst names in
461     let names = List.sort compare names in
462     List.iter print_endline names;
463     exit 0
464   in
465
466   let argspec = Arg.align [
467     "--goals", Arg.Unit list_goals, " List all goals";
468     "-l", Arg.Unit list_goals, " List all goals";
469     "-V", Arg.Unit display_version, " Display version number and exit";
470     "--version", Arg.Unit display_version, " Display version number and exit";
471   ] in
472   let anon_fun str = args := str :: !args in
473   let usage_msg = sprintf "\
474 %s: a script generated by goaljobs
475
476 List all goals:                %s -l
477 Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
478
479 For more information see the goaljobs(1) man page.
480
481 Options:
482 " prog prog prog in
483
484   Arg.parse argspec anon_fun usage_msg;
485
486   let args = List.rev !args in
487
488   (* Was a goal named on the command line? *)
489   (match args with
490   | name :: args ->
491     (match get_goal name with
492     | Some fn ->
493       exit (if guard fn args then 0 else 1)
494     | None ->
495       eprintf "error: no goal called '%s' was found.\n" name;
496       eprintf "Use %s -l to list all published goals in this script.\n" name;
497       exit 1
498     )
499   | [] ->
500     (* If periodic jobs exist, fall through. *)
501     if !periodic_jobs = [] then (
502       (* Does a published 'all' goal exist? *)
503       match get_goal "all" with
504       | Some fn ->
505         exit (if guard fn [] then 0 else 1)
506       | None ->
507         (* No published 'all' goal. *)
508         eprintf "error: no goal called 'all' was found.\n";
509         exit 1
510     )
511   );
512
513   assert (!periodic_jobs <> []);
514
515   (* Run the periodic jobs.  Note these run forever, or until killed. *)
516   while true do
517     (* Find the next job to run. *)
518     let now = time () in
519     let jobs = List.map (
520       fun (period, (_, _ as name_f)) ->
521         next_time now period, name_f
522     ) !periodic_jobs in
523     let jobs = List.sort (fun (t1,_) (t2,_) -> compare t1 t2) jobs in
524
525     (* Find all jobs that have the same next time.
526      * XXX When we can handle parallel jobs we can do better here,
527      * but until them run all the ones which have the same time
528      * in series.
529      *)
530     let next_t = int_of_float (fst (List.hd jobs)) in
531     let jobs = List.filter (fun (t, _) -> int_of_float t = next_t) jobs in
532
533     (* Run next job(s) after waiting for the appropriate amount of time. *)
534     let seconds = next_t - int_of_float now in
535     eprintf "next job will run in %s\n%!" (printable_seconds seconds);
536     sleep seconds;
537
538     List.iter (
539       fun (_, (name, f)) ->
540         eprintf "running job: %s\n%!"
541           (match name with Some name -> name | None -> "[unnamed]");
542         ignore (guard f ())
543     ) jobs
544   done
545
546 and printable_seconds s =
547   if s < 60 then sprintf "%d seconds" s
548   else if s < 6000 then sprintf "%d minutes, %d seconds" (s/60) (s mod 60)
549   else if s < 86400 then sprintf "%d hours, %d minutes" (s/3600) (s/60)
550   else sprintf "about %d days" (s/86400)