2 * Copyright (C) 2013 Red Hat Inc.
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.
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.
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.
24 let (//) = Filename.concat
25 let quote = Filename.quote
27 type goal_result_t = Goal_OK | Goal_failed of string
28 exception Goal_result of goal_result_t
30 let goal_failed msg = raise (Goal_result (Goal_failed msg))
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)
38 let file_exists = Sys.file_exists
40 let file_newer_than f1 f2 =
44 | Unix_error (ENOENT, _, _) -> None
45 | Unix_error (err, _, _) ->
46 let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
49 let s1 = stat f1 and s2 = stat f2 in
55 let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
58 s1.st_mtime >= s2.st_mtime
60 let more_recent objs srcs =
61 if not (List.for_all file_exists objs) then false
64 fun obj -> List.for_all (file_newer_than obj) srcs
69 (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
71 sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
72 match Sys.command cmd with
76 let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
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
85 let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
89 let url_contains_string url str =
90 let tmp = Filename.temp_file "goaljobsurl" "" in
92 sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
93 (match Sys.command cmd with
96 let msg = sprintf "curl failed to download URL '%s'" url in
99 let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
102 let r = file_contains_string tmp str in
106 (* Create a temporary directory. It is *not* deleted on exit. *)
108 let chan = open_in "/dev/urandom" in
109 let data = String.create 16 in
110 really_input chan data 0 (String.length data);
112 let data = Digest.to_hex (Digest.string data) in
113 let dir = Filename.temp_dir_name // sprintf "goaljobstmp%s" data in
117 (* Recursively remove directory. *)
119 let cmd = sprintf "rm -rf %s" (quote dir) in
120 ignore (Sys.command cmd)
122 let shell = ref "/bin/sh"
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.
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) *)
136 output_string chan script;
138 chmod script_file 0o700;
139 let cmd = sprintf "cd %s && exec %s" (quote dir) (quote script_file) in
144 let dir, cmd = create_script script in
145 let r = Sys.command cmd in
148 let msg = sprintf "external command failed with code %d" r in
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
159 let line = input_line chan in
160 lines := line :: !lines;
163 (try loop () with End_of_file -> ());
164 let r = close_process_in chan in
167 | WEXITED 0 -> List.rev !lines
169 let msg = sprintf "external command failed with code %d" i in
172 let msg = sprintf "external command was killed by signal %d" i in
175 let msg = sprintf "external command was stopped by signal %d" i in
177 let shlines fs = ksprintf do_shlines fs
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
185 val replace_substring : string -> string -> string -> string
188 let change_file_extension ext filename =
190 try String.rindex filename '.'
191 with Not_found -> String.length filename in
192 String.sub filename 0 i ^ "." ^ ext
195 val filter_file_extension : string -> string list -> string
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.
202 * XXX Replace this with a more efficient and less fragile implementation.
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
214 | Or exn -> raise exn
216 let memory_exists key =
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
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
232 let memory_set key value =
233 with_memory_locked ~write:true (
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
240 output_value chan memory
243 let memory_delete key =
244 with_memory_locked ~write:true (
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
251 output_value chan memory
254 let published_goals = ref []
255 let publish name fn = published_goals := (name, fn) :: !published_goals
257 try Some (List.assoc name !published_goals) with Not_found -> None
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
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
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
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
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
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
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
296 (* Run the program. *)
298 let prog = Sys.executable_name in
299 let prog = Filename.basename prog in
301 (* Save the current working directory when the program started. *)
302 putenv "builddir" (getcwd ());
306 let display_version () =
307 printf "%s %s\n" package_name package_version;
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
318 let argspec = Arg.align [
319 "--goals", Arg.Unit list_goals, " List all goals";
320 "-l", Arg.Unit list_goals, " List all goals";
321 "-V", Arg.Unit display_version, " Display version number and exit";
322 "--version", Arg.Unit display_version, " Display version number and exit";
324 let anon_fun str = args := str :: !args in
325 let usage_msg = sprintf "\
326 %s: a script generated by goaljobs
328 List all goals: %s -l
329 Run a single goal like this: %s <name-of-goal> [<goal-args ...>]
331 For more information see the goaljobs(1) man page.
336 Arg.parse argspec anon_fun usage_msg;
338 let args = List.rev !args in
340 (* Was a goal named on the command line? *)
343 (match get_goal name with
346 eprintf "error: no goal called '%s' was found.\n" name;
347 eprintf "Use %s -l to list all published goals in this script.\n" name;
351 (* Does a published 'all' goal exist? *)
352 match get_goal "all" with
355 (* No published 'all' goal. This is only a warning, because
356 * other top-level code may exist in the script.
358 eprintf "warning: no 'all' goal found.\n"