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