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 type goal_result_t = Goal_OK | Goal_failed of string
  25 exception Goal_result of goal_result_t
  26
  27 let goal_failed msg = raise (Goal_result (Goal_failed msg))
  28
  29 let target v =
  30   if v then raise (Goal_result Goal_OK)
  31 let target_all vs = target (List.fold_left (&&) true vs)
  32 let target_exists vs = target (List.fold_left (||) false vs)
  33 let require () = ()
  34
  35 let file_exists = Sys.file_exists
  36
  37 let file_newer_than f1 f2 =
  38   let stat f =
  39     try Some (stat f)
  40     with
  41     | Unix_error (ENOENT, _, _) -> None
  42     | Unix_error (err, _, _) ->
  43       let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
  44       goal_failed msg
  45   in
  46   let s1 = stat f1 and s2 = stat f2 in
  47   match s1 with
  48   | None -> false
  49   | Some s1 ->
  50     match s2 with
  51     | None ->
  52       let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
  53       goal_failed msg
  54     | Some s2 ->
  55       s1.st_mtime >= s2.st_mtime
  56
  57 let more_recent objs srcs =
  58   if not (List.for_all file_exists objs) then false
  59   else (
  60     List.for_all (
  61       fun obj -> List.for_all (file_newer_than obj) srcs
  62     ) objs
  63   )
  64
  65 let url_exists url =
  66   (* http://stackoverflow.com/questions/12199059/how-to-check-if-an-url-exists-with-the-shell-and-probably-curl *)
  67   let cmd =
  68     sprintf "curl --output /dev/null --silent --head --fail %s" (quote url) in
  69   match Sys.command cmd with
  70   | 0 -> true
  71   | 1 -> false
  72   | r ->
  73     let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
  74     goal_failed msg
  75
  76 let file_contains_string filename str =
  77   let cmd = sprintf "grep -q %s %s" (quote str) (quote filename) in
  78   match Sys.command cmd with
  79   | 0 -> true
  80   | 1 -> false
  81   | r ->
  82     let msg = sprintf "grep error testing for '%s' in '%s' (exit code %d)"
  83       str filename r in
  84     goal_failed msg
  85
  86 let url_contains_string url str =
  87   let tmp = Filename.temp_file "goaljobsurl" "" in
  88   let cmd =
  89     sprintf "curl --output %s --silent --fail %s" (quote tmp) (quote url) in
  90   (match Sys.command cmd with
  91   | 0 -> ()
  92   | 1 ->
  93     let msg = sprintf "curl failed to download URL '%s'" url in
  94     goal_failed msg
  95   | r ->
  96     let msg = sprintf "curl error testing '%s' (exit code %d)" url r in
  97     goal_failed msg
  98   );
  99   let r = file_contains_string tmp str in
 100   unlink tmp;
 101   r
 102
 103
 104 let sh fs =
 105   let do_sh cmd =
 106     let cmd = "set -e\nset -x\n\n" ^ cmd in
 107     let r = Sys.command cmd in
 108     if r <> 0 then (
 109       let msg = sprintf "external command failed with code %d" r in
 110       goal_failed msg
 111     )
 112   in
 113   ksprintf do_sh fs
 114
 115 let do_shlines cmd =
 116   let cmd = "set -e\nset -x\n\n" ^ cmd in
 117   let chan = open_process_in cmd in
 118   let lines = ref [] in
 119   let rec loop () =
 120     let line = input_line chan in
 121     lines := line :: !lines;
 122     loop ()
 123   in
 124   (try loop () with End_of_file -> ());
 125   let r = close_process_in chan in
 126   match r with
 127   | WEXITED 0 -> List.rev !lines
 128   | WEXITED i ->
 129     let msg = sprintf "external command failed with code %d" i in
 130     goal_failed msg
 131   | WSIGNALED i ->
 132     let msg = sprintf "external command was killed by signal %d" i in
 133     goal_failed msg
 134   | WSTOPPED i ->
 135     let msg = sprintf "external command was stopped by signal %d" i in
 136     goal_failed msg
 137 let shlines fs = ksprintf do_shlines fs
 138
 139 let do_shout cmd =
 140   let lines = do_shlines cmd in
 141   String.concat "\n" lines
 142 let shout fs = ksprintf do_shout fs
 143
 144 (*
 145 val shell : string ref
 146 *)
 147
 148 (*
 149 val replace_substring : string -> string -> string -> string
 150 *)
 151
 152 let change_file_extension ext filename =
 153   let i =
 154     try String.rindex filename '.'
 155     with Not_found -> String.length filename in
 156   String.sub filename 0 i ^ "." ^ ext
 157
 158 (*
 159 val filter_file_extension : string -> string list -> string
 160 *)
 161
 162 (* XXX The Memory is not actually persistent yet. *)
 163 let memory = Hashtbl.create 13
 164
 165 let memory_exists = Hashtbl.mem memory
 166 let memory_set = Hashtbl.replace memory
 167 let memory_get k = try Some (Hashtbl.find memory k) with Not_found -> None
 168 let memory_delete = Hashtbl.remove memory
 169
 170 let published_goals = ref []
 171 let publish name fn = published_goals := (name, fn) :: !published_goals
 172 let get_goal name =
 173   try Some (List.assoc name !published_goals) with Not_found -> None
 174
 175 let goal_file_exists filename =
 176   if not (file_exists filename) then (
 177     let msg = sprintf "file '%s' required but not found" filename in
 178     goal_failed msg
 179   )
 180 let goal_file_newer_than f1 f2 =
 181   if not (file_newer_than f1 f2) then (
 182     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
 183     goal_failed msg
 184   )
 185 let goal_more_recent objs srcs =
 186   if not (more_recent objs srcs) then (
 187     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
 188       (String.concat " " objs) (String.concat " " srcs) in
 189     goal_failed msg
 190   )
 191 let goal_url_exists url =
 192   if not (url_exists url) then (
 193     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
 194     goal_failed msg
 195   )
 196 let goal_file_contains_string filename str =
 197   if not (file_contains_string filename str) then (
 198     let msg = sprintf "file_contains_string: file '%s' is required to contain string '%s'" filename str in
 199     goal_failed msg
 200   )
 201 let goal_url_contains_string url str =
 202   if not (url_contains_string url str) then (
 203     let msg = sprintf "url_contains_string: URL '%s' is required to contain string '%s'" url str in
 204     goal_failed msg
 205   )
 206 let goal_memory_exists k =
 207   if not (memory_exists k) then (
 208     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
 209     goal_failed msg
 210   )
 211
 212 (* Run the program. *)
 213 let init () =
 214   let prog = Sys.executable_name in
 215   let prog = Filename.basename prog in
 216
 217   let args = ref [] in
 218
 219   let display_version () =
 220     printf "%s %s\n" package_name package_version;
 221     exit 0
 222   in
 223
 224   let list_goals () =
 225     let names = !published_goals in
 226     let names = List.map fst names in
 227     let names = List.sort compare names in
 228     List.iter print_endline names
 229   in
 230
 231   let argspec = Arg.align [
 232     "--goals", Arg.Unit list_goals, " List all goals";
 233     "-l", Arg.Unit list_goals, " List all goals";
 234     "-V", Arg.Unit display_version, " Display version number and exit";
 235     "--version", Arg.Unit display_version, " Display version number and exit";
 236   ] in
 237   let anon_fun str = args := str :: !args in
 238   let usage_msg = sprintf "\
 239 %s: a script generated by goaljobs
 240
 241 List all goals:                %s -l
 242 Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
 243
 244 For more information see the goaljobs(1) man page.
 245
 246 Options:
 247 " prog prog prog in
 248
 249   Arg.parse argspec anon_fun usage_msg;
 250
 251   let args = List.rev !args in
 252
 253   (* Was a goal named on the command line? *)
 254   match args with
 255   | name :: args ->
 256     (match get_goal name with
 257     | Some fn -> fn args
 258     | None ->
 259       eprintf "error: no goal called '%s' was found.\n" name;
 260       eprintf "Use %s -l to list all published goals in this script.\n" name;
 261       exit 1
 262     )
 263   | [] ->
 264     (* Does a published 'all' goal exist? *)
 265     match get_goal "all" with
 266     | Some fn -> fn []
 267     | None ->
 268       (* No published 'all' goal.  This is only a warning, because
 269        * other top-level code may exist in the script.
 270        *)
 271       eprintf "warning: no 'all' goal found.\n"