X-Git-Url: http://git.annexia.org/?p=whenjobs.git;a=blobdiff_plain;f=daemon%2Fdaemon.ml;h=bbaab131a1270c40ce237a6f431e7995b9f9c4b0;hp=542c7a48b40ffb255708c766928ca430616aab82;hb=d6da1b74e241e79eb0af9c01e390e98ceead3a49;hpb=21a3155f8296175180e348f10a6a9af88e1ac87d diff --git a/daemon/daemon.ml b/daemon/daemon.ml index 542c7a4..bbaab13 100644 --- a/daemon/daemon.ml +++ b/daemon/daemon.ml @@ -32,11 +32,14 @@ let jobsdir = ref "" (* The state. *) let state = ref Whenstate.empty -(* Jobs that are running; map of PID -> (job, other data). Note that - * the job may no longer exist *OR* it may have been renamed, +(* Jobs that are running: a map of PID -> (job, tmpdir, serial, start_time). + * Note that the job may no longer exist *OR* it may have been renamed, * eg. if the jobs file was reloaded. *) -let running = ref IntMap.empty +let runningmap = ref IntMap.empty + +(* Serial numbers of running jobs. Map of serial -> PID (in runningmap). *) +let serialmap = ref BigIntMap.empty (* Was debugging requested on the command line? *) let debug = ref false @@ -72,6 +75,15 @@ let rec init j d = ~proc_get_variable ~proc_get_variable_names ~proc_exit_daemon + ~proc_get_jobs + ~proc_cancel_job + ~proc_start_job + ~proc_get_job + ~proc_set_variables + ~proc_get_job_names + ~proc_test_variables + ~proc_ping_daemon + ~proc_whisper_variables (Rpc_server.Unix addr) Rpc.Tcp (* not TCP, this is the same as SOCK_STREAM *) Rpc.Socket @@ -87,7 +99,7 @@ let rec init j d = and proc_reload_file () = if !debug then Syslog.notice "remote call: reload_file"; - try reload_file (); `ok + try reload_files (); `ok with Failure err -> `error err and proc_set_variable (name, value) = @@ -100,8 +112,10 @@ and proc_set_variable (name, value) = state := Whenstate.set_variable !state name value; (* Which jobs need to be re-evaluated? *) - let jobs = Whenstate.get_dependencies !state name in - reevaluate_whenjobs jobs; + let jobs = Whenstate.get_dependencies !state [name] in + let jobnames, state' = reevaluate_whenjobs !state jobs in + let state' = run_whenjobs state' jobnames in + state := state'; `ok with @@ -133,9 +147,185 @@ and proc_exit_daemon () = server := None; `ok -(* Reload the jobs file. *) -and reload_file () = - let file = sprintf "%s/jobs.cmo" !jobsdir in +and proc_get_jobs () = + let running = Array.of_list (IntMap.values !runningmap) in + Array.map ( + fun (job, dir, serial, start_time) -> + { Whenproto_aux.job_name = job.job_name; + job_serial = string_of_big_int serial; + job_tmpdir = dir; job_start_time = Int64.of_float start_time } + ) running + +and proc_cancel_job serial = + try + let serial = big_int_of_string serial in + let pid = BigIntMap.find serial !serialmap in + kill pid 15; + `ok + with + | Not_found -> `error "job not found" + | exn -> `error (Printexc.to_string exn) + +and proc_start_job jobname = + try + let job = Whenstate.get_job !state jobname in + let state' = run_job !state job in + state := state'; + `ok + with + | Not_found -> `error "job not found" + | exn -> `error (Printexc.to_string exn) + +and proc_get_job serial = + try + let serial = big_int_of_string serial in + let pid = BigIntMap.find serial !serialmap in + let job, dir, serial, start_time = IntMap.find pid !runningmap in + { Whenproto_aux.job_name = job.job_name; + job_serial = string_of_big_int serial; + job_tmpdir = dir; job_start_time = Int64.of_float start_time } + with + | Not_found -> failwith "job not found" + | exn -> failwith (Printexc.to_string exn) + +and proc_set_variables vars = + try + let vars = Array.map ( + fun { Whenproto_aux.sv_name = name; sv_value = value } -> + name, variable_of_rpc value + ) vars in + let vars = Array.to_list vars in + + if !debug then + Syslog.notice "remote call: set_variables (%s)" + (String.concat " " + (List.map ( + fun (name, value) -> + sprintf "%s=%s" name (string_of_variable value) + ) vars)); + + List.iter (fun (name, _) -> check_valid_variable_name name) vars; + + (* Update all the variables atomically. *) + let s = List.fold_left ( + fun s (name, value) -> Whenstate.set_variable s name value + ) !state vars in + state := s; + + (* Which jobs need to be re-evaluated? *) + let jobs = Whenstate.get_dependencies !state (List.map fst vars) in + let jobnames, state' = reevaluate_whenjobs !state jobs in + let state' = run_whenjobs state' jobnames in + state := state'; + + `ok + with + Failure msg -> `error msg + +and proc_get_job_names () = + Array.of_list (Whenstate.get_job_names !state) + +and proc_test_variables vars = + (* This is the same as proc_set_variables, except that it doesn't + * update the state, it just returns the jobs that *would* run if + * these variables were set to these values. + *) + let vars = Array.map ( + fun { Whenproto_aux.sv_name = name; sv_value = value } -> + name, variable_of_rpc value + ) vars in + let vars = Array.to_list vars in + + if !debug then + Syslog.notice "remote call: test_variables (%s)" + (String.concat " " + (List.map ( + fun (name, value) -> + sprintf "%s=%s" name (string_of_variable value) + ) vars)); + + List.iter (fun (name, _) -> check_valid_variable_name name) vars; + + (* Update all the variables atomically. *) + let state = List.fold_left ( + fun s (name, value) -> Whenstate.set_variable s name value + ) !state vars in + + (* Which jobs WOULD be re-evaluated? *) + let jobs = Whenstate.get_dependencies state (List.map fst vars) in + let jobnames, _ = reevaluate_whenjobs state jobs in + + (* Return the names. *) + Array.of_list jobnames + +and proc_ping_daemon () = `ok + +and proc_whisper_variables vars = + try + let vars = Array.map ( + fun { Whenproto_aux.sv_name = name; sv_value = value } -> + name, variable_of_rpc value + ) vars in + let vars = Array.to_list vars in + + if !debug then + Syslog.notice "remote call: whisper_variables (%s)" + (String.concat " " + (List.map ( + fun (name, value) -> + sprintf "%s=%s" name (string_of_variable value) + ) vars)); + + List.iter (fun (name, _) -> check_valid_variable_name name) vars; + + (* Update all the variables atomically. *) + let s = List.fold_left ( + fun s (name, value) -> Whenstate.set_variable s name value + ) !state vars in + state := s; + + (* .. but don't reevaluate or run jobs. *) + + `ok + with + Failure msg -> `error msg + +(* Reload the jobs file(s). *) +and reload_files () = + (* Get the highest numbered dir/jobs__*.cmo (bytecode) or + * dir/jobs__*.cmxs (native code) file and load it. Delete + * lower-numbered (== older) files. + *) + let filename = + let suffix, slen = + if not Dynlink.is_native then ".cmo", 4 else ".cmxs", 5 in + let dir = !jobsdir in + let files = Array.to_list (Sys.readdir dir) in + let times = filter_map ( + fun file -> + if not (string_startswith file "jobs__") || + not (string_endswith file suffix) then + None + else ( + let len = String.length file in + let t = String.sub file 6 (len-slen-6) in + (* Use int64 because t won't necessarily fit into 31 bit int. *) + try Some (Int64.of_string t) + with Failure "int_of_string" -> assert false + ) + ) files in + let times = List.rev (List.sort compare times) in + match times with + | [] -> None + | x::xs -> + (* Unlink the older files. *) + List.iter ( + fun t -> + try unlink (dir // sprintf "jobs__%Ld%s" t suffix) + with Unix_error _ -> () + ) xs; + (* Return the newest (highest numbered) file. *) + Some (dir // sprintf "jobs__%Ld%s" x suffix) in (* As we are reloading the file, we want to create a new state * that has no jobs, but has all the variables from the previous @@ -145,62 +335,75 @@ and reload_file () = Whenfile.init s; let s = - try - Dynlink.loadfile file; - let s = Whenfile.get_state () in - Syslog.notice "loaded %d job(s) from %s" (Whenstate.nr_jobs s) file; + match filename with + | None -> + (* no jobs file, return the same state *) + Syslog.notice "no jobs file found"; s - with - | Dynlink.Error err -> - let err = Dynlink.error_message err in - Syslog.error "error loading jobs: %s" err; - failwith err - | exn -> - failwith (Printexc.to_string exn) in - + | Some filename -> + try + Dynlink.loadfile filename; + let s = Whenfile.get_state () in + Syslog.notice "loaded %d job(s)" (Whenstate.nr_jobs s); + s + with + | Dynlink.Error err -> + let err = Dynlink.error_message err in + Syslog.error "error loading jobs: %s" err; + failwith err + | exn -> + failwith (Printexc.to_string exn) in + + let s = Whenstate.copy_prev_state !state s in state := s; (* Re-evaluate all when jobs. *) - reevaluate_whenjobs ~onload:true (Whenstate.get_whenjobs !state); + let jobs = Whenstate.get_whenjobs !state in + let jobnames, state' = reevaluate_whenjobs ~onload:true !state jobs in + let state' = run_whenjobs state' jobnames in + state := state'; (* Schedule the next every job to run. *) schedule_next_everyjob () (* Re-evaluate each when-statement job, in a loop until we reach - * a fixpoint. Run those that need to be run. + * a fixpoint. Return the list of job names that should run and + * the updated state. *) -and reevaluate_whenjobs ?onload jobs = - let rec loop set jobs = - let set' = +and reevaluate_whenjobs ?onload state jobs = + let rec loop (set, state) jobs = + let set', state' = List.fold_left ( - fun set job -> + fun (set, state) job -> let r, state' = - try Whenstate.evaluate_whenjob ?onload !state job + try Whenstate.evaluate_whenjob ?onload state job with Invalid_argument err | Failure err -> Syslog.error "error evaluating job %s (at %s): %s" job.job_name (Camlp4.PreCast.Ast.Loc.to_string job.job_loc) err; - false, !state in - - state := state'; + false, state in if !debug then Syslog.notice "evaluate %s -> %b\n" job.job_name r; - if r then StringSet.add job.job_name set else set - ) set jobs in + (if r then StringSet.add job.job_name set else set), state' + ) (set, state) jobs in + (* reached a fixpoint? *) if StringSet.compare set set' <> 0 then - loop set' jobs + loop (set', state') jobs else - set' + (set', state') in - let set = loop StringSet.empty jobs in + let set, state = loop (StringSet.empty, state) jobs in let jobnames = StringSet.elements set in (* Ensure the jobs always run in predictable (name) order. *) let jobnames = List.sort compare_jobnames jobnames in + jobnames, state +and run_whenjobs state jobnames = (* Run the jobs. *) - List.iter run_job (List.map (Whenstate.get_job !state) jobnames) + let jobs = List.map (Whenstate.get_job state) jobnames in + List.fold_left run_job state jobs (* Schedule the next every-statement job to run, if there is one. We * look at the every jobs, work out the time that each must run at, @@ -265,7 +468,8 @@ and schedule_next_everyjob () = let t_diff = if t_diff < 0. then 0. else t_diff in let run_jobs () = delete_timer_group (); (* Delete the timer. *) - List.iter run_job jobs; + let state' = List.fold_left run_job !state jobs in + state := state'; schedule_next_everyjob () in Unixqueue.weak_once esys g t_diff run_jobs; @@ -285,66 +489,101 @@ and delete_timer_group () = Unixqueue.clear esys g; timer_group := None -and string_of_time_t t = - let tm = gmtime t in - sprintf "%04d-%02d-%02d %02d:%02d:%02d UTC" - (1900+tm.tm_year) (1+tm.tm_mon) tm.tm_mday - tm.tm_hour tm.tm_min tm.tm_sec - -and run_job job = - let () = - (* Increment JOBSERIAL. *) - let serial = - match Whenstate.get_variable !state "JOBSERIAL" with - | T_int serial -> - let serial = succ_big_int serial in - state := Whenstate.set_variable !state "JOBSERIAL" (T_int serial); - serial - | _ -> assert false in - - Syslog.notice "running %s (JOBSERIAL=%s)" - job.job_name (string_of_big_int serial) in - - (* Create a temporary directory. The current directory of the job - * will be in this directory. The directory is removed when the - * child process exits. +and run_job state job = + (* Increment JOBSERIAL. *) + let serial, state = + match Whenstate.get_variable state "JOBSERIAL" with + | T_int serial -> + let serial = succ_big_int serial in + let state' = Whenstate.set_variable state "JOBSERIAL" (T_int serial) in + serial, state' + | _ -> assert false in + + (* Call the pre-condition script. Note this may decide not to run + * the job by returning false. *) - let dir = tmpdir () in - - let pid = fork () in - if pid = 0 then ( (* child process running the job *) - chdir dir; - - (* Set environment variables corresponding to each variable. *) - List.iter - (fun (name, value) -> putenv name (string_of_variable value)) - (Whenstate.get_variables !state); - - (* Set the $JOBNAME environment variable. *) - putenv "JOBNAME" job.job_name; - - (* Create a temporary file containing the shell script fragment. *) - let script = dir // "script" in - let chan = open_out script in - fprintf chan "set -e\n"; (* So that jobs exit on error. *) - output_string chan job.job_script.sh_script; - close_out chan; - chmod script 0o700; - - let shell = try getenv "SHELL" with Not_found -> "/bin/sh" in - - (* Execute the shell script. *) - (try execvp shell [| shell; "-c"; script |]; - with Unix_error (err, fn, _) -> - Syslog.error "%s failed: %s: %s" fn script (error_message err) + let pre_condition () = + match job.job_pre with + | None -> true + | Some pre -> + let rs = ref [] in + IntMap.iter ( + fun pid (job, _, serial, start_time) -> + let r = { pirun_job_name = job.job_name; + pirun_serial = serial; + pirun_start_time = start_time; + pirun_pid = pid } in + rs := r :: !rs + ) !runningmap; + let preinfo = { + pi_job_name = job.job_name; + pi_serial = serial; + pi_variables = Whenstate.get_variables state; + pi_running = !rs; + } in + pre preinfo + in + if pre_condition () then ( + Syslog.notice "running %s (JOBSERIAL=%s)" + job.job_name (string_of_big_int serial); + + (* Create a temporary directory. The current directory of the job + * will be in this directory. The directory is removed when the + * child process exits. + *) + let dir = tmpdir () in + + let pid = fork () in + if pid = 0 then ( (* child process running the job *) + chdir dir; + + (* Set environment variables corresponding to each variable. *) + List.iter + (fun (name, value) -> putenv name (string_of_variable value)) + (Whenstate.get_variables state); + + (* Set the $JOBNAME environment variable. *) + putenv "JOBNAME" job.job_name; + + (* Create a temporary file containing the shell script fragment. *) + let script = dir // "script.sh" in + let chan = open_out script in + fprintf chan "set -e\n"; (* So that jobs exit on error. *) + output_string chan job.job_script.sh_script; + close_out chan; + chmod script 0o700; + + let shell = try getenv "SHELL" with Not_found -> "/bin/sh" in + + (* Set output to file. *) + let output = dir // "output.txt" in + let fd = openfile output [O_WRONLY; O_CREAT; O_TRUNC; O_NOCTTY] 0o600 in + dup2 fd stdout; + dup2 fd stderr; + close fd; + + (* Execute the shell script. *) + (try execvp shell [| shell; "-c"; script |]; + with Unix_error (err, fn, _) -> + Syslog.error "%s failed: %s: %s" fn script (error_message err) + ); + _exit 1 ); - _exit 1 - ); - (* Remember this PID, the job and the temporary directory, so we - * can clean up when the child exits. - *) - running := IntMap.add pid (job, dir) !running + (* Remember this PID, the job and the temporary directory, so we + * can clean up when the child exits. + *) + runningmap := IntMap.add pid (job, dir, serial, time ()) !runningmap; + serialmap := BigIntMap.add serial pid !serialmap; + + state + ) + else ( + Syslog.notice "not running %s (JOBSERIAL=%s) because pre() condition returned false" + job.job_name (string_of_big_int serial); + + state + ) and tmpdir () = let chan = open_in "/dev/urandom" in @@ -362,13 +601,39 @@ and handle_sigchld _ = let pid, status = waitpid [WNOHANG] 0 in if pid > 0 then ( (* Look up the PID in the running jobs map. *) - let job, dir = IntMap.find pid !running in - running := IntMap.remove pid !running; - cleanup_job job dir + let job, dir, serial, time = IntMap.find pid !runningmap in + runningmap := IntMap.remove pid !runningmap; + serialmap := BigIntMap.remove serial !serialmap; + post_job job dir serial time status ) with Unix_error _ | Not_found -> () -and cleanup_job job dir = +and post_job job dir serial time status = + (* If there is a post function, run it. *) + (match job.job_post with + | None -> () + | Some post -> + let code = + match status with + | WEXITED c -> c + | WSIGNALED s | WSTOPPED s -> 1 in + let result = { + res_job_name = job.job_name; + res_serial = serial; + res_code = code; + res_tmpdir = dir; + res_output = dir // "output.txt"; + res_start_time = time + } in + try post result + with + | Failure msg -> + Syslog.error "job %s post function failed: %s" job.job_name msg + | exn -> + Syslog.error "job %s post function exception: %s" + job.job_name (Printexc.to_string exn) + ); + (* This should be safe because the path cannot contain shell metachars. *) let cmd = sprintf "rm -rf '%s'" dir in ignore (Sys.command cmd)