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 Unix
  20 open Printf
  21
  22 open Goaljobs_config
  23
  24 let (//) = Filename.concat
  25 let quote = Filename.quote
  26
  27 type goal_result_t = Goal_OK | Goal_failed of string
  28 exception Goal_result of goal_result_t
  29
  30 let goal_failed msg = raise (Goal_result (Goal_failed msg))
  31
  32 let target v =
  33   if v then raise (Goal_result Goal_OK)
  34 let target_all vs = target (List.fold_left (&&) true vs)
  35 let target_exists vs = target (List.fold_left (||) false vs)
  36 let require () = ()
  37
  38 let file_exists = Sys.file_exists
  39
  40 let file_newer_than f1 f2 =
  41   let stat f =
  42     try Some (stat f)
  43     with
  44     | Unix_error (ENOENT, _, _) -> None
  45     | Unix_error (err, _, _) ->
  46       let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
  47       goal_failed msg
  48   in
  49   let s1 = stat f1 and s2 = stat f2 in
  50   match s1 with
  51   | None -> false
  52   | Some s1 ->
  53     match s2 with
  54     | None ->
  55       let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
  56       goal_failed msg
  57     | Some s2 ->
  58       s1.st_mtime >= s2.st_mtime
  59
  60 let more_recent objs srcs =
  61   if not (List.for_all file_exists objs) then false
  62   else (
  63     List.for_all (
  64       fun obj -> List.for_all (file_newer_than obj) srcs
  65     ) objs
  66   )
  67
  68 let url_exists url =
  69   (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
  70   let cmd =
  71     sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
  72   match Sys.command cmd with
  73   | 0 -> true
  74   | 1 -> false
  75   | r ->
  76     let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
  77     goal_failed msg
  78
  79 let file_contains_string filename str =
  80   let cmd = sprintf "grep -q %s %s" (quote str) (quote filename) in
  81   match Sys.command cmd with
  82   | 0 -> true
  83   | 1 -> false
  84   | r ->
  85     let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
  86       str filename r in
  87     goal_failed msg
  88
  89 let url_contains_string url str =
  90   let tmp = Filename.temp_file "goaljobsurl" "" in
  91   let cmd =
  92     sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
  93   (match Sys.command cmd with
  94   | 0 -> ()
  95   | 1 ->
  96     let msg = sprintf "curl failed to download URL '%s'" url in
  97     goal_failed msg
  98   | r ->
  99     let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
 100     goal_failed msg
 101   );
 102   let r = file_contains_string tmp str in
 103   unlink tmp;
 104   r
 105
 106 (* Create a temporary directory.  It is *not* deleted on exit. *)
 107 let tmpdir () =
 108   let chan = open_in "/dev/urandom" in
 109   let data = String.create 16 in
 110   really_input chan data 0 (String.length data);
 111   close_in chan;
 112   let data = Digest.to_hex (Digest.string data) in
 113   let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
 114   mkdir dir 0o700;
 115   dir
 116
 117 (* Recursively remove directory. *)
 118 let rm_rf dir =
 119   let cmd = sprintf "rm -rf %s" (quote dir) in
 120   ignore (Sys.command cmd)
 121
 122 let shell = ref "/bin/sh"
 123
 124 (* Used by sh, shout etc.  Create a temporary directory and a
 125  * 'script.sh' inside it containing the script to run.  Returns the
 126  * temporary directory and command to run.
 127  *)
 128 let create_script script =
 129   let dir = tmpdir () in
 130   let script_file = dir // "script.sh" in
 131   let chan = open_out script_file in
 132   fprintf chan "#!%s\n" !shell;
 133   fprintf chan "set -e\n"; (* so that job exits on error *)
 134   fprintf chan "set -x\n"; (* echo commands (must be last) *)
 135   fprintf chan "\n";
 136   output_string chan script;
 137   close_out chan;
 138   chmod script_file 0o700;
 139   let cmd = sprintf "cd %s && exec %s" (quote dir) (quote script_file) in
 140   dir, cmd
 141
 142 let sh fs =
 143   let do_sh script =
 144     let dir, cmd = create_script script in
 145     let r = Sys.command cmd in
 146     rm_rf dir;
 147     if r <> 0 then (
 148       let msg = sprintf "external command failed with code %d" r in
 149       goal_failed msg
 150     )
 151   in
 152   ksprintf do_sh fs
 153
 154 let do_shlines script =
 155   let dir, cmd = create_script script in
 156   let chan = open_process_in cmd in
 157   let lines = ref [] in
 158   let rec loop () =
 159     let line = input_line chan in
 160     lines := line :: !lines;
 161     loop ()
 162   in
 163   (try loop () with End_of_file -> ());
 164   let r = close_process_in chan in
 165   rm_rf dir;
 166   match r with
 167   | WEXITED 0 -> List.rev !lines
 168   | WEXITED i ->
 169     let msg = sprintf "external command failed with code %d" i in
 170     goal_failed msg
 171   | WSIGNALED i ->
 172     let msg = sprintf "external command was killed by signal %d" i in
 173     goal_failed msg
 174   | WSTOPPED i ->
 175     let msg = sprintf "external command was stopped by signal %d" i in
 176     goal_failed msg
 177 let shlines fs = ksprintf do_shlines fs
 178
 179 let do_shout script =
 180   let lines = do_shlines script in
 181   String.concat "\n" lines
 182 let shout fs = ksprintf do_shout fs
 183
 184 (*
 185 val replace_substring : string -> string -> string -> string
 186 *)
 187
 188 let change_file_extension ext filename =
 189   let i =
 190     try String.rindex filename '.'
 191     with Not_found -> String.length filename in
 192   String.sub filename 0 i ^ "." ^ ext
 193
 194 (*
 195 val filter_file_extension : string -> string list -> string
 196 *)
 197
 198 (* Persistent memory is stored in $HOME/.goaljobs-memory.  We have to
 199  * lock this file each time we read or write because multiple concurrent
 200  * jobs may access it at the same time.
 201  *
 202  * XXX Replace this with a more efficient and less fragile implementation.
 203  *)
 204
 205 type ('a, 'b) alternative = Either of 'a | Or of 'b
 206 let with_memory_locked ?(write = false) f =
 207   let filename = getenv "HOME" // ".goaljobs-memory" in
 208   let fd = openfile filename [O_RDWR; O_CREAT] 0o644 in
 209   lockf fd (if write then F_LOCK else F_RLOCK) 0;
 210   let r = try Either (f fd) with exn -> Or (exn) in
 211   lockf fd F_ULOCK 0;
 212   match r with
 213   | Either x -> x
 214   | Or exn -> raise exn
 215
 216 let memory_exists key =
 217   with_memory_locked (
 218     fun fd ->
 219       let chan = in_channel_of_descr fd in
 220       let memory : (string, string) Hashtbl.t = input_value chan in
 221       Hashtbl.mem memory key
 222   )
 223
 224 let memory_get key =
 225   with_memory_locked (
 226     fun fd ->
 227       let chan = in_channel_of_descr fd in
 228       let memory : (string, string) Hashtbl.t = input_value chan in
 229       try Some (Hashtbl.find memory key) with Not_found -> None
 230   )
 231
 232 let memory_set key value =
 233   with_memory_locked ~write:true (
 234     fun fd ->
 235       let chan = in_channel_of_descr fd in
 236       let memory : (string, string) Hashtbl.t = input_value chan in
 237       Hashtbl.replace memory key value;
 238       let chan = out_channel_of_descr fd in
 239       seek_out chan 0;
 240       output_value chan memory
 241   )
 242
 243 let memory_delete key =
 244   with_memory_locked ~write:true (
 245     fun fd ->
 246       let chan = in_channel_of_descr fd in
 247       let memory : (string, string) Hashtbl.t = input_value chan in
 248       Hashtbl.remove memory key;
 249       let chan = out_channel_of_descr fd in
 250       seek_out chan 0;
 251       output_value chan memory
 252   )
 253
 254 let published_goals = ref []
 255 let publish name fn = published_goals := (name, fn) :: !published_goals
 256 let get_goal name =
 257   try Some (List.assoc name !published_goals) with Not_found -> None
 258
 259 let goal_file_exists filename =
 260   if not (file_exists filename) then (
 261     let msg = sprintf "file '%s' required but not found" filename in
 262     goal_failed msg
 263   )
 264 let goal_file_newer_than f1 f2 =
 265   if not (file_newer_than f1 f2) then (
 266     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
 267     goal_failed msg
 268   )
 269 let goal_more_recent objs srcs =
 270   if not (more_recent objs srcs) then (
 271     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
 272       (String.concat " " objs) (String.concat " " srcs) in
 273     goal_failed msg
 274   )
 275 let goal_url_exists url =
 276   if not (url_exists url) then (
 277     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
 278     goal_failed msg
 279   )
 280 let goal_file_contains_string filename str =
 281   if not (file_contains_string filename str) then (
 282     let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
 283     goal_failed msg
 284   )
 285 let goal_url_contains_string url str =
 286   if not (url_contains_string url str) then (
 287     let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
 288     goal_failed msg
 289   )
 290 let goal_memory_exists k =
 291   if not (memory_exists k) then (
 292     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
 293     goal_failed msg
 294   )
 295
 296 (* Run the program. *)
 297 let init () =
 298   let prog = Sys.executable_name in
 299   let prog = Filename.basename prog in
 300
 301   (* Save the current working directory when the program started. *)
 302   putenv "builddir" (getcwd ());
 303
 304   let args = ref [] in
 305
 306   let display_version () =
 307     printf "%s %s\n" package_name package_version;
 308     exit 0
 309   in
 310
 311   let list_goals () =
 312     let names = !published_goals in
 313     let names = List.map fst names in
 314     let names = List.sort compare names in
 315     List.iter print_endline names;
 316     exit 0
 317   in
 318
 319   let argspec = Arg.align [
 320     "--goals", Arg.Unit list_goals, " List all goals";
 321     "-l", Arg.Unit list_goals, " List all goals";
 322     "-V", Arg.Unit display_version, " Display version number and exit";
 323     "--version", Arg.Unit display_version, " Display version number and exit";
 324   ] in
 325   let anon_fun str = args := str :: !args in
 326   let usage_msg = sprintf "\
 327 %s: a script generated by goaljobs
 328
 329 List all goals:                %s -l
 330 Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
 331
 332 For more information see the goaljobs(1) man page.
 333
 334 Options:
 335 " prog prog prog in
 336
 337   Arg.parse argspec anon_fun usage_msg;
 338
 339   let args = List.rev !args in
 340
 341   (* Was a goal named on the command line? *)
 342   match args with
 343   | name :: args ->
 344     (match get_goal name with
 345     | Some fn -> fn args
 346     | None ->
 347       eprintf "error: no goal called '%s' was found.\n" name;
 348       eprintf "Use %s -l to list all published goals in this script.\n" name;
 349       exit 1
 350     )
 351   | [] ->
 352     (* Does a published 'all' goal exist? *)
 353     match get_goal "all" with
 354     | Some fn -> fn []
 355     | None ->
 356       (* No published 'all' goal.  This is only a warning, because
 357        * other top-level code may exist in the script.
 358        *)
 359       eprintf "warning: no 'all' goal found.\n"