tools/whenjobs.ml

   1 (* whenjobs daemon
   2  * Copyright (C) 2012 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 Big_int
  20 open Unix
  21 open Printf
  22
  23 open Whenutils
  24
  25 (* Ensures that Whentools module is linked to the whenjobs tool. *)
  26 let _ = Whentools.set_variable
  27
  28 let libdir = ref Libdir.libdir
  29
  30 let jobsdir =
  31   (* Running the program as root is a mistake.  It must be run as a
  32    * non-root user.
  33    *)
  34   let euid = geteuid () in
  35   if euid = 0 then (
  36     eprintf "whenjobs: this program must not be run as root\n";
  37     exit 1
  38   );
  39
  40   (* $HOME must be defined and must exist and be a directory and must be
  41    * owned by the current user.
  42    *)
  43   let home =
  44     try getenv "HOME"
  45     with Not_found ->
  46       eprintf "whenjobs: $HOME environment variable must be defined\n";
  47       exit 1 in
  48
  49   let stat =
  50     try lstat home
  51     with Unix_error (err, fn, _) ->
  52       eprintf "whenjobs: %s: %s ($HOME): %s\n" fn home (error_message err);
  53       exit 1 in
  54   if stat.st_kind != S_DIR then (
  55     eprintf "whenjobs: %s ($HOME): not a directory\n" home;
  56     exit 1
  57   );
  58
  59   if stat.st_uid != euid then (
  60     eprintf "whenjobs: %s ($HOME): not owned by the current user (uid %d)\n"
  61       home euid;
  62     exit 1
  63   );
  64
  65   (* Make the $HOME/.whenjobs directory if it doesn't exist. *)
  66   let jobsdir = sprintf "%s/.whenjobs" home in
  67   (try mkdir jobsdir 0o700 with Unix_error _ -> ());
  68
  69   jobsdir
  70
  71 let rec main () =
  72   (* Parse the command line arguments. *)
  73   let mode = ref None in
  74   let typ = ref "string" in
  75
  76   let set_mode m () = mode := Some m in
  77
  78   let display_version () =
  79     printf "%s %s\n" Config.package_name Config.package_version;
  80     exit 0
  81   in
  82
  83   let argspec = Arg.align [
  84     "--cancel", Arg.Unit (set_mode `Cancel), " Cancel a job";
  85     "--daemon-start", Arg.Unit (set_mode `Daemon_start), " Start the daemon";
  86     "--daemon-status", Arg.Unit (set_mode `Daemon_status), " Display the status of the daemon";
  87     "--daemon-stop", Arg.Unit (set_mode `Daemon_stop), " Stop the daemon";
  88     "--daemon-restart", Arg.Unit (set_mode `Daemon_restart), " Restart the daemon";
  89     "-e", Arg.Unit (set_mode `Edit), " Edit and upload the script";
  90     "--edit", Arg.Unit (set_mode `Edit), " Edit and upload the script";
  91     "--get", Arg.Unit (set_mode `Get), "var Display the variable";
  92     "--jobs", Arg.Unit (set_mode `Jobs), " List running jobs";
  93     "-l", Arg.Unit (set_mode `List), " List the script";
  94     "--list", Arg.Unit (set_mode `List), " List the script";
  95     "--lib", Arg.Set_string libdir, "dir Specify directory that contains pa_when.cmo";
  96     "--set", Arg.Unit (set_mode `Set), " Set the variable";
  97     "--start", Arg.Unit (set_mode `Start), "name Start a job manually";
  98     "--tail", Arg.Unit (set_mode `Tail), "serial Tail job output";
  99     "--type", Arg.Set_string typ, "bool|int|float|string|unit Set the variable type";
 100     "--upload", Arg.Unit (set_mode `Upload), " Upload the script";
 101     "--variables", Arg.Unit (set_mode `Variables), " Display all variables and values";
 102     "-V", Arg.Unit display_version, " Display version number and exit";
 103     "--version", Arg.Unit display_version, " Display version number and exit";
 104   ] in
 105
 106   let args = ref [] in
 107   let anon_fun str = args := str :: !args in
 108
 109   let usage_msg = "\
 110 Whenjobs is a powerful but simple cron replacement.
 111 Whenjobs copyright (C) 2012 Red Hat Inc.
 112
 113 Editing the script:
 114
 115   whenjobs -e | --edit
 116   whenjobs -l | --list
 117
 118 Get and set variables:
 119
 120   whenjobs --get variable
 121   whenjobs --set variable value
 122
 123 Start and stop the per-user daemon:
 124
 125   whenjobs --daemon-start | --daemon-stop | --daemon-status
 126
 127 For documentation see the whenjobs(1) man page.
 128
 129 Options:
 130 " in
 131
 132   Arg.parse argspec anon_fun usage_msg;
 133
 134   let mode = !mode in
 135   let args = List.rev !args in
 136
 137   let typ = match !typ with
 138     | "bool"|"boolean" -> `Bool
 139     | "string" -> `String
 140     | "int" -> `Int
 141     | "float"|"double" -> `Float
 142     | "unit" -> `Unit
 143     | t ->
 144       eprintf "whenjobs: --type: unknown type (%s)\n" t;
 145       exit 1 in
 146
 147   (* Depending on the selected mode, perform a different action. *)
 148   match mode with
 149   | None ->
 150     eprintf "whenjobs: no operation selected.\n";
 151     suggest_help ();
 152     exit 1
 153
 154   | Some `Edit ->
 155     unused_error args "-e";
 156     edit_file ()
 157
 158   | Some `List ->
 159     unused_error args "-l";
 160     list_file ()
 161
 162   | Some `Upload ->
 163     unused_error args "--upload";
 164     upload_file ()
 165
 166   | Some `Set ->
 167     if List.length args != 2 then (
 168       eprintf "whenjobs --set variable value\n";
 169       eprintf "If 'value' contains spaces, you may need to quote it.\n";
 170       suggest_help ();
 171       exit 1
 172     );
 173     set_variable (List.hd args) (List.hd (List.tl args)) typ
 174
 175   | Some `Get ->
 176     if List.length args != 1 then (
 177       eprintf "whenjobs --get variable\n";
 178       suggest_help ();
 179       exit 1
 180     );
 181     get_variable (List.hd args)
 182
 183   | Some `Variables ->
 184     unused_error args "--variables";
 185     list_variables ()
 186
 187   | Some `Daemon_start ->
 188     unused_error args "--daemon-start";
 189     daemon_start ()
 190
 191   | Some `Daemon_stop ->
 192     unused_error args "--daemon-stop";
 193     daemon_stop ()
 194
 195   | Some `Daemon_restart ->
 196     unused_error args "--daemon-restart";
 197     daemon_restart ()
 198
 199   | Some `Daemon_status ->
 200     unused_error args "--daemon-status";
 201     daemon_status ()
 202
 203   | Some `Jobs ->
 204     unused_error args "--jobs";
 205     jobs ()
 206
 207   | Some `Cancel ->
 208     if List.length args != 1 then (
 209       eprintf "whenjobs --cancel serial\n";
 210       suggest_help ();
 211       exit 1
 212     );
 213     cancel_job (List.hd args)
 214
 215   | Some `Start ->
 216     if List.length args != 1 then (
 217       eprintf "whenjobs --start jobname\n";
 218       eprintf "If 'value' contains spaces, you may need to quote it.\n";
 219       suggest_help ();
 220       exit 1
 221     );
 222     start_job (List.hd args)
 223
 224   | Some `Tail ->
 225     if List.length args != 1 then (
 226       eprintf "whenjobs --tail serial\n";
 227       suggest_help ();
 228       exit 1
 229     );
 230     tail (List.hd args)
 231
 232 and edit_file () =
 233   (* If there is no initial file, create an empty one containing the
 234    * tutorial.
 235    *)
 236   let file = get_jobs_filename () in
 237   if not (Sys.file_exists file) then
 238     create_tutorial file;
 239
 240   (* Is $EDITOR set?  If not, use a default. *)
 241   let editor = try getenv "EDITOR" with Not_found -> "vi" in
 242
 243   (* Get the (size, MD5) of the file to tell if it changed. *)
 244   let file_stamp () =
 245     try (lstat file).st_size, Digest.file file
 246     with Unix_error (err, fn, _) ->
 247       eprintf "whenjobs: %s: %s: %s\n" fn file (error_message err);
 248       exit 1
 249   in
 250   let old_stamp = file_stamp () in
 251
 252   let cmd = sprintf "%s %s" editor file in
 253   if Sys.command cmd != 0 then (
 254     eprintf "whenjobs: error editing file (is $EDITOR set correctly?)\n";
 255     exit 1
 256   );
 257
 258   let new_stamp = file_stamp () in
 259
 260   if old_stamp <> new_stamp then
 261     upload_file ()
 262
 263 and list_file () =
 264   let file = get_jobs_filename () in
 265   if not (Sys.file_exists file) then (
 266     eprintf "whenjobs: there is no jobs file, use 'whenjobs -e' to create one\n";
 267     exit 1
 268   );
 269   let chan = open_in file in
 270   let rec loop () =
 271     printf "%s\n" (input_line chan);
 272     loop ()
 273   in
 274   (try loop () with End_of_file -> ());
 275   close_in chan
 276
 277 and upload_file () =
 278   (* Recompile the jobs file. *)
 279   let file = get_jobs_filename () in
 280   let cmo_file = sprintf "%s/jobs.cmo" jobsdir in
 281   let cmd = sprintf "ocamlfind ocamlc -I +camlp4 -I %s -package unix,camlp4.lib -pp 'camlp4o %s/pa_when.cmo' -c %s -o %s"
 282     !libdir !libdir file cmo_file in
 283   if Sys.command cmd <> 0 then (
 284     eprintf "whenjobs: could not compile jobs script, see earlier error messages\n";
 285     eprintf "compile command was:\n%s\n" cmd;
 286     exit 1
 287   );
 288
 289   (* Test-load the jobs file to ensure it makes sense. *)
 290   Whenfile.init Whenstate.empty;
 291   (try
 292      Dynlink.loadfile cmo_file
 293    with
 294      Dynlink.Error err ->
 295        eprintf "whenjobs: %s\n" (Dynlink.error_message err);
 296        (* Since it failed, unlink it. *)
 297        (try unlink cmo_file with Unix_error _ -> ());
 298        exit 1
 299   );
 300
 301   (* OK now let's tell the daemon to reload it. *)
 302   let client = start_client () in
 303   (match Whenproto_clnt.When.V1.reload_file client () with
 304   | `ok -> ()
 305   | `error msg ->
 306     eprintf "whenjobs: reload: %s\n" msg;
 307     suggest_check_server_logs ();
 308     exit 1
 309   );
 310   stop_client client
 311
 312 and set_variable name value typ =
 313   let value = match typ with
 314     | `Bool ->
 315       (match value with
 316       | "true"|"t"|"yes"|"y"|"on"|"1" -> `bool_t true
 317       | "false"|"f"|"no"|"n"|"off"|"0" -> `bool_t false
 318       | _ ->
 319         eprintf "whenjobs: variable does not have a boolean value\n";
 320         exit 1
 321       )
 322     | `String -> `string_t value
 323     | `Int ->
 324       (try ignore (big_int_of_string value)
 325        with Failure _ ->
 326          eprintf "whenjobs: variable is not an integer\n";
 327          exit 1
 328       );
 329       `int_t value (* the string is what we pass over the wire *)
 330     | `Float ->
 331       (try `float_t (float_of_string value)
 332        with Failure _ ->
 333          eprintf "whenjobs: variable is not a floating point number\n";
 334          exit 1
 335       )
 336     | `Unit ->
 337       if value <> "" then (
 338         eprintf "whenjobs: unit variables must be empty strings\n";
 339         exit 1
 340       );
 341       `unit_t in
 342
 343   let client = start_client () in
 344   (match Whenproto_clnt.When.V1.set_variable client (name, value) with
 345   | `ok -> ()
 346   | `error msg ->
 347     eprintf "whenjobs: set: %s\n" msg;
 348     suggest_check_server_logs ();
 349     exit 1
 350   );
 351   stop_client client
 352
 353 and get_variable name =
 354   let client = start_client () in
 355   let value = Whenproto_clnt.When.V1.get_variable client name in
 356   print_endline (string_of_variable value);
 357   stop_client client
 358
 359 and list_variables () =
 360   let client = start_client () in
 361   let names = Whenproto_clnt.When.V1.get_variable_names client () in
 362   Array.iter (
 363     fun name ->
 364       let value = Whenproto_clnt.When.V1.get_variable client name in
 365       printf "%s=%s\n" name (string_of_variable value)
 366   ) names;
 367   stop_client client
 368
 369 and daemon_start () =
 370   assert false
 371
 372 and daemon_stop () =
 373   let client = start_client () in
 374   (match Whenproto_clnt.When.V1.exit_daemon client () with
 375   | `ok -> ()
 376   | `error msg ->
 377     eprintf "whenjobs: daemon-stop: %s\n" msg;
 378     suggest_check_server_logs ();
 379     exit 1
 380   );
 381   stop_client client
 382
 383 and daemon_restart () =
 384   assert false
 385
 386 and daemon_status () =
 387   assert false
 388
 389 and jobs () =
 390   let client = start_client () in
 391   let jobs = Whenproto_clnt.When.V1.get_jobs client () in
 392   stop_client client;
 393
 394   let cmp { Whenproto_aux.job_name = name1; job_serial = serial1 }
 395       { Whenproto_aux.job_name = name2; job_serial = serial2 } =
 396     let i = compare name1 name2 in
 397     if i <> 0 then i
 398     else
 399       compare_big_int (big_int_of_string serial1) (big_int_of_string serial2)
 400   in
 401   Array.sort cmp jobs;
 402
 403   Array.iter (
 404     fun { Whenproto_aux.job_serial = serial; job_name = name;
 405           job_tmpdir = tmpdir; job_start_time = time } ->
 406       printf "%s %s\n\trunning in: %s\n\tstarted at: %s\n"
 407         serial name tmpdir
 408         (string_of_time_t ~localtime:true (Int64.to_float time))
 409   ) jobs
 410
 411 and cancel_job serial =
 412   let client = start_client () in
 413   (match Whenproto_clnt.When.V1.cancel_job client serial with
 414   | `ok -> ()
 415   | `error msg ->
 416     eprintf "whenjobs: cancel-job: %s\n" msg;
 417     suggest_check_server_logs ();
 418     exit 1
 419   );
 420   stop_client client
 421
 422 and start_job name =
 423   let client = start_client () in
 424   (match Whenproto_clnt.When.V1.start_job client name with
 425   | `ok -> ()
 426   | `error msg ->
 427     eprintf "whenjobs: start-job: %s\n" msg;
 428     suggest_check_server_logs ();
 429     exit 1
 430   );
 431   stop_client client
 432
 433   (* This only works for local.  If we ever make whenjobs work
 434    * remotely we'll have to change the implementation to use
 435    * the server.
 436    *)
 437 and tail serial =
 438   let client = start_client () in
 439   let job = Whenproto_clnt.When.V1.get_job client serial in
 440   stop_client client;
 441   let cmd =
 442     sprintf "tail -f %s/output.txt"
 443       (Filename.quote job.Whenproto_aux.job_tmpdir) in
 444   exit (Sys.command cmd)
 445
 446 and unused_error args op =
 447   if args <> [] then (
 448     eprintf "whenjobs %s: unused parameters on the command line.\n" op;
 449     suggest_help ();
 450     exit 1
 451   )
 452
 453 and suggest_help () =
 454   eprintf "Use 'whenjobs --help' for a summary of options or read whenjobs(1) man page.\n"
 455
 456 and suggest_check_server_logs () =
 457   eprintf "Look at the server logs (/var/log/cron or /var/log/syslog usually) for\n";
 458   eprintf "further information on why this daemon operation failed.\n"
 459
 460 and get_jobs_filename () =
 461   sprintf "%s/jobs.ml" jobsdir
 462
 463 and create_tutorial file =
 464   let chan = open_out file in
 465   output_string chan Tutorial.tutorial;
 466   close_out chan
 467
 468 and start_client () =
 469   let addr = sprintf "%s/socket" jobsdir in
 470   let client =
 471     try
 472       Whenproto_clnt.When.V1.create_client
 473         (Rpc_client.Unix addr)
 474         Rpc.Tcp (* not TCP, this is the same as SOCK_STREAM *)
 475     with
 476     | Unix_error ((ECONNREFUSED|ENOENT), _, _) ->
 477       eprintf "whenjobs: error: the daemon ('whenjobsd') is not running\n";
 478       eprintf "Use 'whenjobs --daemon-start' to start the daemon.\n";
 479       exit 1
 480     | Unix_error (err, fn, _) ->
 481       eprintf "whenjobs: %s: %s: %s\n" fn addr (error_message err);
 482       exit 1 in
 483   client
 484
 485 and stop_client client =
 486   Rpc_client.shut_down client
 487
 488 and string_of_variable = function
 489   | `unit_t -> ""
 490   | `bool_t b -> string_of_bool b
 491   | `string_t s -> s
 492   | `int_t i -> i (* passed on the wire as a string *)
 493   | `float_t f -> string_of_float f
 494
 495 let () =
 496   try main ()
 497   with
 498     (* Pretty print some of the exceptions that main can throw. *)
 499   | Rpc.Rpc_server err ->
 500     eprintf "whenjobs: rpc error: %s\n" (Rpc.string_of_server_error err);
 501     suggest_check_server_logs ();
 502     exit 1
 503   | Failure msg ->
 504     eprintf "whenjobs: error: %s\n" msg;
 505     exit 1
 506   | Invalid_argument msg ->
 507     eprintf "whenjobs: invalid argument: %s\n" msg;
 508     exit 1
 509   | exn ->
 510     eprintf "whenjobs: error: %s\n" (Printexc.to_string exn);
 511     exit 1