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