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 () = ()
  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   | 1 -> false
 191   | r ->
 192     let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
 193     goal_failed msg
 194
 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
 198   | 0 -> true
 199   | 1 -> false
 200   | r ->
 201     let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
 202       str filename r in
 203     goal_failed msg
 204
 205 let url_contains_string url str =
 206   let tmp = Filename.temp_file "goaljobsurl" "" in
 207   let cmd =
 208     sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
 209   (match Sys.command cmd with
 210   | 0 -> ()
 211   | 1 ->
 212     let msg = sprintf "curl failed to download URL '%s'" url in
 213     goal_failed msg
 214   | r ->
 215     let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
 216     goal_failed msg
 217   );
 218   let r = file_contains_string tmp str in
 219   unlink tmp;
 220   r
 221
 222 (* Create a temporary directory.  It is *not* deleted on exit. *)
 223 let tmpdir () =
 224   let chan = open_in "/dev/urandom" in
 225   let data = String.create 16 in
 226   really_input chan data 0 (String.length data);
 227   close_in chan;
 228   let data = Digest.to_hex (Digest.string data) in
 229   let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
 230   mkdir dir 0o700;
 231   dir
 232
 233 (* Recursively remove directory. *)
 234 let rm_rf dir =
 235   let cmd = sprintf "rm -rf %s" (quote dir) in
 236   ignore (Sys.command cmd)
 237
 238 let shell = ref "/bin/sh"
 239
 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.
 243  *)
 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) *)
 251   fprintf chan "\n";
 252   output_string chan script;
 253   close_out chan;
 254   chmod script_file 0o700;
 255   let cmd = sprintf "cd %s && exec %s" (quote dir) (quote script_file) in
 256   dir, cmd
 257
 258 let sh fs =
 259   let do_sh script =
 260     let dir, cmd = create_script script in
 261     let r = Sys.command cmd in
 262     rm_rf dir;
 263     if r <> 0 then (
 264       let msg = sprintf "external command failed with code %d" r in
 265       goal_failed msg
 266     )
 267   in
 268   ksprintf do_sh fs
 269
 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
 274   let rec loop () =
 275     let line = input_line chan in
 276     lines := line :: !lines;
 277     loop ()
 278   in
 279   (try loop () with End_of_file -> ());
 280   let r = close_process_in chan in
 281   rm_rf dir;
 282   match r with
 283   | WEXITED 0 -> List.rev !lines
 284   | WEXITED i ->
 285     let msg = sprintf "external command failed with code %d" i in
 286     goal_failed msg
 287   | WSIGNALED i ->
 288     let msg = sprintf "external command was killed by signal %d" i in
 289     goal_failed msg
 290   | WSTOPPED i ->
 291     let msg = sprintf "external command was stopped by signal %d" i in
 292     goal_failed msg
 293 let shlines fs = ksprintf do_shlines fs
 294
 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
 299
 300 (*
 301 val replace_substring : string -> string -> string -> string
 302 *)
 303
 304 let change_file_extension ext filename =
 305   let i =
 306     try String.rindex filename '.'
 307     with Not_found -> String.length filename in
 308   String.sub filename 0 i ^ "." ^ ext
 309
 310 (*
 311 val filter_file_extension : string -> string list -> string
 312 *)
 313
 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.
 317  *
 318  * XXX Replace this with a more efficient and less fragile implementation.
 319  *)
 320
 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   (* If the file is newly created with zero size, write an
 327    * empty hash table.
 328    *)
 329   if (fstat fd).st_size = 0 then (
 330     let empty : (string, string) Hashtbl.t = Hashtbl.create 13 in
 331     let chan = out_channel_of_descr fd in
 332     output_value chan empty;
 333     Pervasives.flush chan;
 334     ignore (lseek fd 0 SEEK_SET)
 335   );
 336
 337   (* Run the function. *)
 338   let r = try Either (f fd) with exn -> Or (exn) in
 339   lockf fd F_ULOCK 0;
 340   match r with
 341   | Either x -> x
 342   | Or exn -> raise exn
 343
 344 let memory_exists key =
 345   with_memory_locked (
 346     fun fd ->
 347       let chan = in_channel_of_descr fd in
 348       let memory : (string, string) Hashtbl.t = input_value chan in
 349       Hashtbl.mem memory key
 350   )
 351
 352 let memory_get key =
 353   with_memory_locked (
 354     fun fd ->
 355       let chan = in_channel_of_descr fd in
 356       let memory : (string, string) Hashtbl.t = input_value chan in
 357       try Some (Hashtbl.find memory key) with Not_found -> None
 358   )
 359
 360 let memory_set key value =
 361   with_memory_locked ~write:true (
 362     fun fd ->
 363       let chan = in_channel_of_descr fd in
 364       let memory : (string, string) Hashtbl.t = input_value chan in
 365       Hashtbl.replace memory key value;
 366       let chan = out_channel_of_descr fd in
 367       seek_out chan 0;
 368       output_value chan memory;
 369       Pervasives.flush chan;
 370   )
 371
 372 let memory_delete key =
 373   with_memory_locked ~write:true (
 374     fun fd ->
 375       let chan = in_channel_of_descr fd in
 376       let memory : (string, string) Hashtbl.t = input_value chan in
 377       Hashtbl.remove memory key;
 378       let chan = out_channel_of_descr fd in
 379       seek_out chan 0;
 380       output_value chan memory;
 381       Pervasives.flush chan;
 382   )
 383
 384 let published_goals = ref []
 385 let publish name fn = published_goals := (name, fn) :: !published_goals
 386 let get_goal name =
 387   try Some (List.assoc name !published_goals) with Not_found -> None
 388
 389 let goal_file_exists filename =
 390   if not (file_exists filename) then (
 391     let msg = sprintf "file '%s' required but not found" filename in
 392     goal_failed msg
 393   )
 394 let goal_directory_exists path =
 395   if not (directory_exists path) then (
 396     let msg = sprintf "directory '%s' required but not found" path in
 397     goal_failed msg
 398   )
 399 let goal_file_newer_than f1 f2 =
 400   if not (file_newer_than f1 f2) then (
 401     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
 402     goal_failed msg
 403   )
 404 let goal_more_recent objs srcs =
 405   if not (more_recent objs srcs) then (
 406     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
 407       (String.concat " " objs) (String.concat " " srcs) in
 408     goal_failed msg
 409   )
 410 let goal_url_exists url =
 411   if not (url_exists url) then (
 412     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
 413     goal_failed msg
 414   )
 415 let goal_file_contains_string filename str =
 416   if not (file_contains_string filename str) then (
 417     let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
 418     goal_failed msg
 419   )
 420 let goal_url_contains_string url str =
 421   if not (url_contains_string url str) then (
 422     let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
 423     goal_failed msg
 424   )
 425 let goal_memory_exists k =
 426   if not (memory_exists k) then (
 427     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
 428     goal_failed msg
 429   )
 430
 431 let guard fn arg =
 432   try fn arg; true
 433   with
 434   | Goal_result (Goal_failed msg) ->
 435     prerr_endline ("error: " ^ msg);
 436     false
 437   | exn ->
 438     prerr_endline (Printexc.to_string exn);
 439     false
 440
 441 (* Run the program. *)
 442 let rec init () =
 443   let prog = Sys.executable_name in
 444   let prog = Filename.basename prog in
 445
 446   (* Save the current working directory when the program started. *)
 447   putenv "builddir" (getcwd ());
 448
 449   let args = ref [] in
 450
 451   let display_version () =
 452     printf "%s %s\n" package_name package_version;
 453     exit 0
 454   in
 455
 456   let list_goals () =
 457     let names = !published_goals in
 458     let names = List.map fst names in
 459     let names = List.sort compare names in
 460     List.iter print_endline names;
 461     exit 0
 462   in
 463
 464   let argspec = Arg.align [
 465     "--goals", Arg.Unit list_goals, " List all goals";
 466     "-l", Arg.Unit list_goals, " List all goals";
 467     "-V", Arg.Unit display_version, " Display version number and exit";
 468     "--version", Arg.Unit display_version, " Display version number and exit";
 469   ] in
 470   let anon_fun str = args := str :: !args in
 471   let usage_msg = sprintf "\
 472 %s: a script generated by goaljobs
 473
 474 List all goals:                %s -l
 475 Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
 476
 477 For more information see the goaljobs(1) man page.
 478
 479 Options:
 480 " prog prog prog in
 481
 482   Arg.parse argspec anon_fun usage_msg;
 483
 484   let args = List.rev !args in
 485
 486   (* Was a goal named on the command line? *)
 487   (match args with
 488   | name :: args ->
 489     (match get_goal name with
 490     | Some fn ->
 491       exit (if guard fn args then 0 else 1)
 492     | None ->
 493       eprintf "error: no goal called '%s' was found.\n" name;
 494       eprintf "Use %s -l to list all published goals in this script.\n" name;
 495       exit 1
 496     )
 497   | [] ->
 498     (* If periodic jobs exist, fall through. *)
 499     if !periodic_jobs = [] then (
 500       (* Does a published 'all' goal exist? *)
 501       match get_goal "all" with
 502       | Some fn ->
 503         exit (if guard fn [] then 0 else 1)
 504       | None ->
 505         (* No published 'all' goal. *)
 506         eprintf "error: no goal called 'all' was found.\n";
 507         exit 1
 508     )
 509   );
 510
 511   assert (!periodic_jobs <> []);
 512
 513   (* Run the periodic jobs.  Note these run forever, or until killed. *)
 514   while true do
 515     (* Find the next job to run. *)
 516     let now = time () in
 517     let jobs = List.map (
 518       fun (period, (_, _ as name_f)) ->
 519         next_time now period, name_f
 520     ) !periodic_jobs in
 521     let jobs = List.sort (fun (t1,_) (t2,_) -> compare t1 t2) jobs in
 522
 523     (* Find all jobs that have the same next time.
 524      * XXX When we can handle parallel jobs we can do better here,
 525      * but until them run all the ones which have the same time
 526      * in series.
 527      *)
 528     let next_t = int_of_float (fst (List.hd jobs)) in
 529     let jobs = List.filter (fun (t, _) -> int_of_float t = next_t) jobs in
 530
 531     (* Run next job(s) after waiting for the appropriate amount of time. *)
 532     let seconds = next_t - int_of_float now in
 533     eprintf "next job will run in %s\n%!" (printable_seconds seconds);
 534     sleep seconds;
 535
 536     List.iter (
 537       fun (_, (name, f)) ->
 538         eprintf "running job: %s\n%!"
 539           (match name with Some name -> name | None -> "[unnamed]");
 540         ignore (guard f ())
 541     ) jobs
 542   done
 543
 544 and printable_seconds s =
 545   if s < 60 then sprintf "%d seconds" s
 546   else if s < 6000 then sprintf "%d minutes, %d seconds" (s/60) (s mod 60)
 547   else if s < 86400 then sprintf "%d hours, %d minutes" (s/3600) (s/60)
 548   else sprintf "about %d days" (s/86400)