The new 'fe' daemon requests and file descriptors over a unix domain socket and calls fork/exec/waitpid on behalf of clients.
Signed-off-by: Jon Ludlam <Jonathan.Ludlam@eu.citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
.PHONY: all
all:
$(MAKE) -C uuid
+ifeq ($(HAVE_TYPECONV),type-conv)
+ $(MAKE) -C rpc-light
+endif
$(MAKE) -C stdext
$(MAKE) -C log
$(MAKE) -C stunnel
$(MAKE) -C http-svr
$(MAKE) -C close-and-exec
$(MAKE) -C sexpr
-ifeq ($(HAVE_TYPECONV),type-conv)
- $(MAKE) -C rpc-light
-endif
+
ifeq ($(HAVE_XMLM),xmlm)
$(MAKE) -C xml-light2
$(MAKE) -C rss
make -C close-and-exec clean
make -C sexpr clean
make -C doc clean
+ make -C forking_executioner clean
cleanxen:
$(MAKE) -C mmap clean
LDFLAGS = -cclib -L./
LIBEXEC = "/opt/xensource/libexec"
-INIT_D = "/etc/rc.d/init.d"
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
libs: $(LIBS)
test_forker: test_forker.cmx
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../uuid -I ../stdext uuid.cmxa rpc.cmx jsonrpc.cmx -I ../log unix.cmxa stdext.cmxa test_forker.cmx -o $@
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../uuid -I ../stdext uuid.cmxa jsonrpc.cmxa -I ../log unix.cmxa stdext.cmxa test_forker.cmx -o $@
fe: fe_debug.cmx child.cmx fe_main.cmx
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../stdext -I ../uuid -I ../log log.cmxa uuid.cmxa unix.cmxa rpc.cmx jsonrpc.cmx stdext.cmxa fe_debug.cmx child.cmx fe_main.cmx -o $@
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../stdext -I ../uuid -I ../log log.cmxa uuid.cmxa unix.cmxa jsonrpc.cmxa stdext.cmxa fe_debug.cmx child.cmx fe_main.cmx -o $@
%.cmo: %.ml
$(OCAMLC) -c -I ../log -I ../uuid -I ../stdext -thread -o $@ $<
.PHONY: bininstall
bininstall: path = $(DESTDIR)$(LIBEXEC)
bininstall: all
- mkdir -p $(DESTDIR)$(LIBEXEC)
- $(IPROG) $(PROGRAMS) $(DESTDIR)$(LIBEXEC)
- mkdir -p $(DESTDIR)$(INIT_D)
- $(IPROG) init.d-fe $(DESTDIR)$(INIT_D)/fe
+ mkdir -p $(path)
+ $(IPROG) $(PROGRAMS) $(path)
.PHONY: uninstall
uninstall:
.PHONY: binuninstall
binuninstall:
rm -f $(DESTDIR)$(LIBEXEC)$(PROGRAMS)
- rm -f $(DESTDIR)$(INIT_D)/fe
.PHONY: doc
doc:
let handle_fd_sock fd_sock state =
try
let (newfd,buffer) = Fecomms.receive_named_fd fd_sock in
- if Unixext.int_of_file_descr newfd = -1 then begin
- debug "Failed to receive an fd associated with the message '%s'" buffer;
- failwith "Didn't get an fd"
- end;
let dest_fd = List.assoc buffer state.id_to_fd_map in
let fd = begin
match dest_fd with
in
try
+ dbuffer := Buffer.create 500;
+
debug "Started: state.cmdargs = [%s]" (String.concat ";" (state.cmdargs));
debug "Started: state.env = [%s]" (String.concat ";" (state.env));
(* Now let's close everything except those fds mentioned in the ids_received list *)
Unixext.close_all_fds_except ([Unix.stdin; Unix.stdout; Unix.stderr] @ fds);
- (* Distance ourselves from our parent process: *)
- if Unix.setsid () == -1 then failwith "Unix.setsid failed";
-
(* And exec *)
Unix.execve (List.hd args) (Array.of_list args) (Array.of_list state.env)
end else begin
List.iter (fun fd -> Unix.close fd) fds;
let (pid,status) = Unix.waitpid [] result in
-
- let log_failure reason code =
- (* The commandline might be too long to clip it *)
- let cmdline = String.concat " " args in
- let limit = 80 - 3 in
- let cmdline' = if String.length cmdline > limit then String.sub cmdline 0 limit ^ "..." else cmdline in
- Syslog.log Syslog.Syslog Syslog.Err (Printf.sprintf "%d (%s) %s %d" result cmdline' reason code) in
-
let pr = match status with
- | Unix.WEXITED 0 -> Fe.WEXITED 0
- | Unix.WEXITED n ->
- log_failure "exitted with code" n;
- Fe.WEXITED n
- | Unix.WSIGNALED n ->
- log_failure "exitted with signal" n;
- Fe.WSIGNALED n
- | Unix.WSTOPPED n ->
- log_failure "stopped with signal" n;
- Fe.WSTOPPED n
+ | Unix.WEXITED n -> Fe.WEXITED n
+ | Unix.WSIGNALED n -> Fe.WSIGNALED n
+ | Unix.WSTOPPED n -> Fe.WSTOPPED n
in
let result = Fe.Finished (pr) in
Fecomms.write_raw_rpc comms_sock result;
| e ->
debug "Caught unexpected exception: %s" (Printexc.to_string e);
write_log ();
- Unixext.unlink_safe fd_sock_path;
exit 1
let log_path = "/var/log/fe.log"
-let debug_log = ref []
+let dbuffer = ref (Buffer.create 1)
let gettimestring () =
let time = Unix.gettimeofday () in
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
(int_of_float (1000.0 *. msec))
-let reset () = debug_log := []
+let reset () = dbuffer := Buffer.create 100
let debug (fmt : ('a, unit, string, unit) format4) =
- Printf.kprintf (fun s -> debug_log := Printf.sprintf "%s|%d|%s\n" (gettimestring ()) (Unix.getpid ()) s :: !debug_log) fmt
+ Printf.kprintf (fun s -> ignore(Printf.bprintf !dbuffer "%s|%d|%s\n" (gettimestring ()) (Unix.getpid ()) s)) fmt
let write_log () =
- List.iter (Syslog.log Syslog.Syslog Syslog.Err) (List.rev !debug_log)
+ let logfile = Unix.openfile log_path [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND] 0o644 in
+ Unixext.really_write_string logfile (Buffer.contents !dbuffer);
+ Unix.close logfile
-
-(** We write our PID here when we're ready to receive connections. *)
-let default_pidfile = "/var/run/fe.pid"
-
open Fe_debug
let setup sock cmdargs id_to_fd_map env =
end
let _ =
- let pidfile = ref default_pidfile in
- let daemonize = ref false in
-
- Arg.parse (Arg.align [
- "-daemon", Arg.Set daemonize, "Create a daemon";
- "-pidfile", Arg.Set_string pidfile, Printf.sprintf "Set the pid file (default \"%s\")" !pidfile;
- ])
- (fun _ -> failwith "Invalid argument")
- "Usage: fe [-daemon] [-pidfile filename]";
-
- if !daemonize then Unixext.daemonize ();
-
+ (* Unixext.daemonize ();*)
Sys.set_signal Sys.sigpipe (Sys.Signal_ignore);
let main_sock = Fecomms.open_unix_domain_sock_server "/var/xapi/forker/main" in
- Unixext.pidfile_write !pidfile;
-
- (* At this point the init.d script should return and we are listening on our socket. *)
-
while true do
try
let (sock,addr) = Unix.accept main_sock in
version = "@VERSION@"
description = "Stdext - Common stdlib extensions"
-requires = "unix,uuid,bigarray"
+requires = "unix,uuid,bigarray,rpc-light,jsonrpc"
archive(byte) = "stdext.cma"
archive(native) = "stdext.cmxa"
OCAMLLIBDIR := $(OCAMLLOC)
OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+FEPP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma
+
OCAML_TEST_INC = -I $(shell ocamlfind query oUnit)
OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa
STDEXT_OBJS = filenameext stringext arrayext hashtblext listext pervasiveext threadext ring \
- qring fring opt bigbuffer unixext range vIO trie config date encodings forkhelpers \
- gzip sha1sum zerocheck base64 backtrace tar
+ qring fring opt bigbuffer unixext range vIO trie config date encodings fe fecomms \
+ forkhelpers gzip sha1sum zerocheck base64 backtrace tar
INTF = $(foreach obj, $(STDEXT_OBJS),$(obj).cmi)
LIBS = stdext.cma stdext.cmxa
threadext.cmo: threadext.ml threadext.cmi
$(OCAMLC) -thread -c -o $@ $<
+fecomms.cmo : fecomms.ml
+ $(OCAMLC) -I ../rpc-light -c -o $@ $<
+
+fe.cmo: fe.ml
+ $(OCAMLC) -pp '$(FEPP)' -I ../jsonrpc -I ../rpc-light -c -o $@ $<
+
forkhelpers.cmo: forkhelpers.ml forkhelpers.cmi
- $(OCAMLC) -thread -c -o $@ $<
+ $(OCAMLC) -thread -I ../uuid -c -o $@ $<
filenameext.cmo: filenameext.ml filenameext.cmi
$(OCAMLC) -c -I ../uuid -o $@ $<
filenameext.cmi: filenameext.mli
$(OCAMLC) -c -I ../uuid -o $@ $<
+fe.cmi: fe.cmo
+ $(OCAMLC) -pp '$(FEPP)' -c -o $@ $<
+
%.cmi: %.mli
$(OCAMLC) -c -o $@ $<
+fe.cmx: fe.ml
+ $(OCAMLOPT) -pp '$(FEPP)' -I ../rpc-light -c -o $@ $<
+
threadext.cmx: threadext.ml threadext.cmi
$(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<
+fecomms.cmx : fecomms.ml
+ $(OCAMLOPT) -I ../rpc-light -c -o $@ $<
+
forkhelpers.cmx: forkhelpers.ml forkhelpers.cmi
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../uuid -thread -c -o $@ $<
filenameext.cmx: filenameext.ml filenameext.cmi
$(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -I ../uuid -o $@ $<
Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0
let open_unix_domain_sock_server path =
- Unixext.mkdir_rec (Filename.dirname path) 0o755;
Unixext.unlink_safe path;
let sock = open_unix_domain_sock () in
Unix.bind sock (Unix.ADDR_UNIX path);
open Pervasiveext
+type pidty =
+ | Stdfork of int (* We've forked and execed, and therefore need to waitpid *)
+ | FEFork of (Unix.file_descr * int) (* The forking executioner has been used, therefore we need to tell it to waitpid *)
+ | Nopid
+
+let string_of_pidty p =
+ match p with
+ | Stdfork pid -> Printf.sprintf "(Stdfork %d)" pid
+ | FEFork (fd,pid) -> Printf.sprintf "(FEFork (%d,%d))" (Unixext.int_of_file_descr fd) pid
+ | Nopid -> "Nopid"
+
+let nopid = Nopid
+
(** Standalone wrapper process which safely closes fds before exec()ing another
program *)
| None -> Unix.execv argv0 args
| Some env -> Unix.execve argv0 args env
with _ -> exit 1
- end else pid
+ end else Stdfork pid
(** File descriptor operations to be performed after a fork.
These are all safe in the presence of threads *)
| Dup2(a, b) -> Unix.dup2 a b
| Close a -> Unix.close a
-(** Safe function which forks a command, closing all fds except a whitelist and
- having performed some fd operations in the child *)
-let safe_close_and_exec ?env (pre_exec: fd_operation list) (fds: Unix.file_descr list)
- (cmd: string) (args: string list) =
- let cmdline = close_and_exec_cmdline fds cmd args in
- fork_and_exec ~pre_exec:(fun () -> List.iter do_fd_operation pre_exec) ?env cmdline
exception Subprocess_failed of int
exception Subprocess_killed of int
-let waitpid pid = match Unix.waitpid [] pid with
- | _, Unix.WEXITED 0 -> ()
- | _, Unix.WEXITED n -> raise (Subprocess_failed n)
- | _, Unix.WSIGNALED n -> raise (Subprocess_killed n)
- | _, Unix.WSTOPPED n -> raise (Subprocess_killed n)
+let waitpid ty =
+ match ty with
+ | Stdfork pid ->
+ Unix.waitpid [] pid
+ | FEFork (sock,pid) ->
+ let status = Fecomms.read_raw_rpc sock in
+ Unix.close sock;
+ begin match status with
+ | Fe.Finished (Fe.WEXITED n) -> (pid,Unix.WEXITED n)
+ | Fe.Finished (Fe.WSIGNALED n) -> (pid,Unix.WSIGNALED n)
+ | Fe.Finished (Fe.WSTOPPED n) -> (pid,Unix.WSTOPPED n)
+ end
+ | Nopid -> failwith "Can't waitpid without a process"
+
+let waitpid_nohang ty =
+ match ty with
+ | Stdfork pid ->
+ Unix.waitpid [Unix.WNOHANG] pid
+ | FEFork (sock,pid) ->
+ (match Unix.select [sock] [] [] 0.0 with
+ | ([s],_,_) -> waitpid ty
+ | _ -> (0,Unix.WEXITED 0))
+ | Nopid ->
+ failwith "Can't waitpid without a pid"
+
+let dontwaitpid ty =
+ match ty with
+ | Stdfork pid ->
+ failwith "Can't do this!"
+ | FEFork (sock,pid) ->
+ Unix.close sock
+ | Nopid -> ()
+
+
+let waitpid_fail_if_bad_exit ty =
+ let (_,status) = waitpid ty in
+ match status with
+ | (Unix.WEXITED 0) -> ()
+ | (Unix.WEXITED n) -> raise (Subprocess_failed n)
+ | (Unix.WSIGNALED n) -> raise (Subprocess_killed n)
+ | (Unix.WSTOPPED n) -> raise (Subprocess_killed n)
+
+let getpid ty =
+ match ty with
+ | Stdfork pid -> pid
+ | FEFork (sock,pid) -> pid
+ | Nopid -> failwith "No pid!"
type 'a result = Success of string * 'a | Failure of string * exn
exception Spawn_internal_error of string * string * Unix.process_status
-(* Execute a command, return the stdout logging or throw a Spawn_internal_error exception *)
+let id = ref 0
+
+(** Safe function which forks a command, closing all fds except a whitelist and
+ having performed some fd operations in the child *)
+let safe_close_and_exec ?env stdin stdout stderr (fds: (string * Unix.file_descr) list)
+ (cmd: string) (args: string list) =
+
+ let sock = Fecomms.open_unix_domain_sock_client "/var/xapi/forker/main" in
+ let stdinuuid = Uuid.to_string (Uuid.make_uuid ()) in
+ let stdoutuuid = Uuid.to_string (Uuid.make_uuid ()) in
+ let stderruuid = Uuid.to_string (Uuid.make_uuid ()) in
+
+ let fds_to_close = ref [] in
+
+ let add_fd_to_close_list fd = fds_to_close := fd :: !fds_to_close in
+ let remove_fd_from_close_list fd = fds_to_close := List.filter (fun fd' -> fd' <> fd) !fds_to_close in
+ let close_fds () = List.iter (fun fd -> Unix.close fd) !fds_to_close in
+
+ finally (fun () ->
+
+ let maybe_add_id_to_fd_map id_to_fd_map (uuid,fd,v) =
+ match v with
+ | Some _ -> (uuid, fd)::id_to_fd_map
+ | None -> id_to_fd_map
+ in
+
+ let predefined_fds = [
+ (stdinuuid, Some 0, stdin);
+ (stdoutuuid, Some 1, stdout);
+ (stderruuid, Some 2, stderr)]
+ in
+
+ (* We don't care what fd these end up as - they're named in the argument list for us, and the
+ forking executioner will sort it out. *)
+ let dest_named_fds = List.map (fun (uuid,_) -> (uuid,None)) fds in
+ let id_to_fd_map = List.fold_left maybe_add_id_to_fd_map dest_named_fds predefined_fds in
+
+ let env = match env with
+ | Some e -> e
+ | None -> [||]
+ in
+ Fecomms.write_raw_rpc sock (Fe.Setup {Fe.cmdargs=(cmd::args); env=(Array.to_list env); id_to_fd_map = id_to_fd_map});
+
+ let response = Fecomms.read_raw_rpc sock in
+
+ let s = match response with
+ | Fe.Setup_response s -> s
+ | _ -> failwith "Failed to communicate with forking executioner"
+ in
+
+ let fd_sock = Fecomms.open_unix_domain_sock_client s.Fe.fd_sock_path in
+ add_fd_to_close_list fd_sock;
+
+ let send_named_fd uuid fd =
+ Fecomms.send_named_fd fd_sock uuid fd;
+ in
+
+ List.iter (fun (uuid,_,srcfdo) ->
+ match srcfdo with Some srcfd -> send_named_fd uuid srcfd | None -> ()) predefined_fds;
+ List.iter (fun (uuid,srcfd) ->
+ send_named_fd uuid srcfd) fds;
+ Fecomms.write_raw_rpc sock Fe.Exec;
+ match Fecomms.read_raw_rpc sock with Fe.Execed pid -> FEFork (sock, pid))
+
+ close_fds
+
+
let execute_command_get_output ?(cb_set=(fun _ -> ())) ?(cb_clear=(fun () -> ())) cmd args =
- let (stdout_exit, stdout_entrance) = Unix.pipe () in
- let fds_to_close = ref [ stdout_exit; stdout_entrance ] in
- let close' fd =
- if List.mem fd !fds_to_close
- then (Unix.close fd; fds_to_close := List.filter (fun x -> x <> fd) !fds_to_close) in
-
- let pid = ref 0 in
- finally (* make sure I close all my open fds in the end *)
- (fun () ->
- (* Open /dev/null for reading. This will be given to the closeandexec process as its STDIN. *)
- with_dev_null_read (fun devnull_read ->
- (* Capture stderr output for logging *)
- match with_logfile_fd "execute_command_get_output"
- (fun log_fd ->
- pid := safe_close_and_exec
- [ Dup2(devnull_read, Unix.stdin);
- Dup2(stdout_entrance, Unix.stdout);
- Dup2(log_fd, Unix.stderr);
- Close(stdout_exit) ]
- [ Unix.stdin; Unix.stdout; Unix.stderr ] (* close all but these *)
- cmd args;
- (* parent *)
- (try cb_set !pid with _ -> ());
- close' stdout_entrance;
- let output = (try Unixext.read_whole_file 500 500 stdout_exit with _ -> "") in
- output, snd(Unix.waitpid [] !pid)) with
- | Success(log, (output, status)) ->
- begin match status with
- | Unix.WEXITED 0 -> output, log
- | _ -> raise (Spawn_internal_error(log, output, status))
- end
- | Failure(log, exn) ->
- raise exn
- )
- ) (fun () ->
- (try cb_clear () with _ -> ());
- List.iter Unix.close !fds_to_close)
+ match with_logfile_fd "execute_command_get_out" (fun out_fd ->
+ with_logfile_fd "execute_command_get_err" (fun err_fd ->
+ let FEFork (sock,pid) = safe_close_and_exec None (Some out_fd) (Some err_fd) [] cmd args in
+ match Fecomms.read_raw_rpc sock with
+ | Fe.Finished x -> Unix.close sock; x
+ | _ -> Unix.close sock; failwith "Communications error"
+ )) with
+ | Success(out,Success(err,(status))) ->
+ begin
+ match status with
+ | Fe.WEXITED 0 -> (out,err)
+ | Fe.WEXITED n -> raise (Spawn_internal_error(err,out,Unix.WEXITED n))
+ | Fe.WSTOPPED n -> raise (Spawn_internal_error(err,out,Unix.WSTOPPED n))
+ | Fe.WSIGNALED n -> raise (Spawn_internal_error(err,out,Unix.WSIGNALED n))
+ end
+ | Success(_,Failure(_,exn))
+ | Failure(_, exn) ->
+ raise exn
+
exception Subprocess_killed of int
exception Spawn_internal_error of string * string * Unix.process_status
+type pidty
+
+val string_of_pidty : pidty -> string
+
+val nopid : pidty
+
(** Standalone wrapper process which safely closes fds before exec()ing another
program *)
val close_and_exec : string
(** Low-level (unsafe) function which forks, runs a 'pre_exec' function and
then executes some other binary. It makes sure to catch any exception thrown by
exec* so that we don't end up with two ocaml processes. *)
-val fork_and_exec : ?pre_exec:(unit -> unit) -> ?env:string array -> string list -> int
+val fork_and_exec : ?pre_exec:(unit -> unit) -> ?env:string array -> string list -> pidty
(** Safe function which forks a command, closing all fds except a whitelist and
having performed some fd operations in the child *)
-val safe_close_and_exec : ?env:string array -> fd_operation list -> Unix.file_descr list -> string -> string list -> int
+val safe_close_and_exec : ?env:string array -> Unix.file_descr option -> Unix.file_descr option -> Unix.file_descr option -> (string * Unix.file_descr) list -> string -> string list -> pidty
type 'a result = Success of string * 'a | Failure of string * exn
(** Execute a command, return the stdout logging or throw a Spawn_internal_error exception *)
val execute_command_get_output : ?cb_set:(int -> unit) -> ?cb_clear:(unit -> unit) -> string -> string list -> string * string
-val waitpid : int -> unit
+val waitpid : pidty -> (int * Unix.process_status)
+val waitpid_nohang : pidty -> (int * Unix.process_status)
+val dontwaitpid : pidty -> unit
+val waitpid_fail_if_bad_exit : pidty -> unit
+val getpid : pidty -> int
val with_dev_null : (Unix.file_descr -> 'a) -> 'a
(fun () ->
let args = if mode = Compress then [] else ["--decompress"] @ [ "--stdout"; "--force" ] in
- let dups, close_now, close_later = match input with
+ let stdin, stdout, close_now, close_later = match input with
| Active ->
- [ Forkhelpers.Dup2(fd, Unix.stdout); (* supplied fd is written to *)
- Forkhelpers.Dup2(zcat_out, Unix.stdin) ], (* input comes from the pipe+fn *)
+ Some zcat_out, (* input comes from the pipe+fn *)
+ Some fd, (* supplied fd is written to *)
zcat_out, (* we close this now *)
zcat_in (* close this before waitpid *)
| Passive ->
- [ Forkhelpers.Dup2(fd, Unix.stdin); (* supplied fd is read from *)
- Forkhelpers.Dup2(zcat_in, Unix.stdout) ], (* output goes into the pipe+fn *)
+ Some fd, (* supplied fd is read from *)
+ Some zcat_in, (* output goes into the pipe+fn *)
zcat_in, (* we close this now *)
zcat_out in (* close this before waitpid *)
- let pid = Forkhelpers.safe_close_and_exec dups
- [ Unix.stdout; Unix.stdin; ] (* close all but these *)
- gzip args in
+ let pid = Forkhelpers.safe_close_and_exec stdin stdout None [] gzip args in
close close_now;
finally
(fun () -> f close_later)
failwith msg
in
close close_later;
- match snd (Unix.waitpid [] pid) with
+ match snd (Forkhelpers.waitpid pid) with
| Unix.WEXITED 0 -> ();
| Unix.WEXITED i -> failwith_error (Printf.sprintf "exit code %d" i)
| Unix.WSIGNALED i -> failwith_error (Printf.sprintf "killed by signal %d" i)
finally
(fun () ->
let args = [] in
- let pid = Forkhelpers.safe_close_and_exec
- [ Forkhelpers.Dup2(result_in, Unix.stdout);
- Forkhelpers.Dup2(input_out, Unix.stdin) ]
- [ Unix.stdout; Unix.stdin; ] (* close all but these *)
- sha1sum args in
+ let pid = Forkhelpers.safe_close_and_exec (Some input_out) (Some result_in) None [] sha1sum args in
close result_in;
close input_out;
close result_out;
result)
(fun () ->
- match Unix.waitpid [] pid with
- | _, Unix.WEXITED 0 -> ()
- | _, _ ->
- let msg = "sha1sum failed (non-zero error code or signal?)" in
- Printf.eprintf "%s" msg;
- failwith msg
+ Forkhelpers.waitpid_fail_if_bad_exit pid
)
) (fun () -> List.iter close !to_close)
if not(List.mem i fds') then close' i
done
-exception Process_output_error of string
-let get_process_output ?(handler) cmd : string =
- let inchan = Unix.open_process_in cmd in
-
- let buffer = Buffer.create 1024
- and buf = String.make 1024 '\000' in
-
- let rec read_until_eof () =
- let rd = input inchan buf 0 1024 in
- if rd = 0 then
- ()
- else (
- Buffer.add_substring buffer buf 0 rd;
- read_until_eof ()
- ) in
- (* Make sure an exception doesn't prevent us from waiting for the child process *)
- (try read_until_eof () with _ -> ());
- match (Unix.close_process_in inchan), handler with
- | Unix.WEXITED 0, _ -> Buffer.contents buffer
- | Unix.WEXITED n, Some handler -> handler cmd n
- | _ -> raise (Process_output_error cmd)
(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *)
let resolve_dot_and_dotdot (path: string) : string =
let http_get = Http.get
let http_put = Http.put
+
+external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd"
+external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd"
val int_of_file_descr : Unix.file_descr -> int
val file_descr_of_int : int -> Unix.file_descr
val close_all_fds_except : Unix.file_descr list -> unit
-val get_process_output : ?handler:(string -> int -> string) -> string -> string
val resolve_dot_and_dotdot : string -> string
val seek_to : Unix.file_descr -> int -> int
val http_get: open_tcp:(server:string -> (in_channel * out_channel)) -> uri:string -> filename:string -> server:string -> unit
(** Upload a file via an HTTP PUT *)
val http_put: open_tcp:(server:string -> (in_channel * out_channel)) -> uri:string -> filename:string -> server:string -> unit
+
+external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd"
+external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd"
#include <errno.h>
#include <netinet/tcp.h>
#include <netinet/in.h>
+#include <sys/un.h>
#include <string.h>
#include <unistd.h> /* needed for _SC_OPEN_MAX */
#include <stdio.h> /* snprintf */
CAMLreturn(Bool_val(ret == 0));
}
+
+static int msg_flag_table[] = {
+ MSG_OOB, MSG_DONTROUTE, MSG_PEEK
+};
+
+#define UNIX_BUFFER_SIZE 16384
+
+CAMLprim value stub_unix_send_fd(value sock, value buff, value ofs, value len, value flags, value fd)
+{
+ CAMLparam5(sock,buff,ofs,len,flags);
+ CAMLxparam1(fd);
+ int ret, cv_flags, cfd;
+ long numbytes;
+ char iobuf[UNIX_BUFFER_SIZE];
+ value path;
+ int pathlen;
+ char buf[CMSG_SPACE(sizeof(cfd))];
+
+ cfd = Int_val(fd);
+
+ cv_flags = convert_flag_list(flags,msg_flag_table);
+
+ numbytes = Long_val(len);
+ if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+ memmove(iobuf, &Byte(buff, Long_val(ofs)), numbytes);
+
+ /* Set up sockaddr */
+
+ struct msghdr msg;
+ struct iovec vec;
+ struct cmsghdr *cmsg;
+
+ msg.msg_name = NULL;
+ msg.msg_namelen = 0;
+ vec.iov_base=iobuf;
+ vec.iov_len=numbytes;
+ msg.msg_iov=&vec;
+ msg.msg_iovlen=1;
+
+ msg.msg_control = buf;
+ msg.msg_controllen = sizeof(buf);
+ cmsg = CMSG_FIRSTHDR(&msg);
+ cmsg->cmsg_level = SOL_SOCKET;
+ cmsg->cmsg_type = SCM_RIGHTS;
+ cmsg->cmsg_len = CMSG_LEN(sizeof(cfd));
+ *(int*)CMSG_DATA(cmsg) = cfd;
+ msg.msg_controllen = cmsg->cmsg_len;
+
+ msg.msg_flags = 0;
+
+ caml_enter_blocking_section();
+ ret=sendmsg(Int_val(sock), &msg, cv_flags);
+ caml_leave_blocking_section();
+
+ if(ret == -1)
+ unixext_error(errno);
+
+ CAMLreturn(Val_int(ret));
+}
+
+CAMLprim value stub_unix_send_fd_bytecode(value *argv, int argn)
+{
+ return stub_unix_send_fd(argv[0],argv[1],argv[2],argv[3],
+ argv[4], argv[5]);
+}
+
+CAMLprim value stub_unix_recv_fd(value sock, value buff, value ofs, value len, value flags)
+{
+ CAMLparam5(sock,buff,ofs,len,flags);
+ CAMLlocal2(res,addr);
+ int ret, cv_flags, fd;
+ long numbytes;
+ char iobuf[UNIX_BUFFER_SIZE];
+ char buf[CMSG_SPACE(sizeof(fd))];
+ struct sockaddr_un unix_socket_name;
+
+ cv_flags = convert_flag_list(flags,msg_flag_table);
+
+ struct msghdr msg;
+ struct iovec vec;
+ struct cmsghdr *cmsg;
+
+ numbytes = Long_val(len);
+ if(numbytes > UNIX_BUFFER_SIZE)
+ numbytes = UNIX_BUFFER_SIZE;
+
+ msg.msg_name=&unix_socket_name;
+ msg.msg_namelen=sizeof(unix_socket_name);
+ vec.iov_base=iobuf;
+ vec.iov_len=numbytes;
+ msg.msg_iov=&vec;
+
+ msg.msg_iovlen=1;
+
+ msg.msg_control = buf;
+ msg.msg_controllen = sizeof(buf);
+
+ caml_enter_blocking_section();
+ ret=recvmsg(Int_val(sock), &msg, cv_flags);
+ caml_leave_blocking_section();
+
+ if(ret == -1)
+ unixext_error(errno);
+
+ if(ret> 0) {
+ cmsg = CMSG_FIRSTHDR(&msg);
+ if(cmsg->cmsg_level == SOL_SOCKET && (cmsg->cmsg_type == SCM_RIGHTS)) {
+ fd=Val_int(*(int*)CMSG_DATA(cmsg));
+ } else {
+ failwith("Failed to receive an fd!");
+ }
+ } else {
+ fd=Val_int(-1);
+ }
+
+ if(ret<numbytes)
+ numbytes = ret;
+
+ memmove(&Byte(buff, Long_val(ofs)), iobuf, numbytes);
+
+ addr=alloc_small(1,0);
+
+ if(ret>0) {
+ Field(addr,0) = copy_string(unix_socket_name.sun_path);
+ } else {
+ Field(addr,0) = copy_string("nothing");
+ }
+
+ res=alloc_small(3,0);
+ Field(res,0) = Val_int(ret);
+ Field(res,1) = addr;
+ Field(res,2) = fd;
+
+ CAMLreturn(res);
+}
version = "@VERSION@"
description = "Secure Tunneling"
-requires = "unix,stdext,log"
+requires = "uuid,unix,stdext,log"
archive(byte) = "stunnel.cma"
archive(native) = "stunnel.cmxa"
$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
%.cmo: %.ml
- $(OCAMLC) -c -I ../stdext -I ../log -o $@ $<
+ $(OCAMLC) -c -I ../stdext -I ../uuid -I ../log -o $@ $<
%.cmi: %.mli
- $(OCAMLC) -c -o $@ $<
+ $(OCAMLC) -c -I ../stdext -I ../uuid -o $@ $<
%.cmx: %.ml
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -I ../stdext -I ../log -o $@ $<
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -I ../stdext -I ../uuid -I ../log -o $@ $<
%.o: %.c
$(CC) $(CFLAGS) -c -o $@ $<
.PHONY: doc
doc: $(INTF)
python ../doc/doc.py $(DOCDIR) "stunnel" "package" "$(OBJS)" "." "stdext,log" ""
-
+
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
| Some p -> p
| None -> raise Stunnel_binary_missing
-type t = { mutable pid: int; fd: Unix.file_descr; host: string; port: int;
+
+type t = { mutable pid: Forkhelpers.pidty; fd: Unix.file_descr; host: string; port: int;
connected_time: float;
unique_id: int option;
mutable logfile: string;
let disconnect x =
List.iter (ignore_exn Unix.close) [ x.fd ];
- ignore_exn Forkhelpers.waitpid x.pid
+ ignore_exn Forkhelpers.waitpid_fail_if_bad_exit x.pid
(* With some probability, stunnel fails during its startup code before it reads
the config data from us. Therefore we get a SIGPIPE writing the config data.
assert (not extended_diagnosis); (* !!! Unimplemented *)
let data_out,data_in = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
let args = [ "-m"; "client"; "-s"; "-"; "-d"; Printf.sprintf "%s:%d" host port ] in
- let t = { pid = 0; fd = data_out; host = host; port = port;
+ let t = { pid = Forkhelpers.nopid; fd = data_out; host = host; port = port;
connected_time = Unix.gettimeofday (); unique_id = unique_id;
logfile = "" } in
let to_close = ref [ data_in ] in
let fds_needed = [ Unix.stdin; Unix.stdout; Unix.stderr ] in
t.pid <- (
if use_external_fd_wrapper then
- Forkhelpers.safe_close_and_exec fdops fds_needed (stunnel_path ()) args
+ Forkhelpers.safe_close_and_exec (Some data_in) (Some data_in) (Some logfd) [] (stunnel_path ()) args
else
- Forkhelpers.fork_and_exec ~pre_exec:(fun _ ->
+ Forkhelpers.fork_and_exec ~pre_exec:(fun _ ->
List.iter Forkhelpers.do_fd_operation fdops;
Unixext.close_all_fds_except fds_needed
- ) ((stunnel_path ()) :: args)
+ ) ((stunnel_path ()) :: args)
);
List.iter Unix.close [ data_in ];
) in
let data_out,data_in = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0
and config_out, config_in = Unix.pipe ()
in
+ let config_out_uuid = Uuid.to_string (Uuid.make_uuid ()) in
(* FDs we must close. NB stdin_in and stdout_out end up in our 't' record *)
let to_close = ref [ data_in; config_out; config_in ] in
let close fd =
if List.mem fd !to_close
then (Unix.close fd; to_close := List.filter (fun x -> x <> fd) !to_close) in
- let t = { pid = 0; fd = data_out; host = host; port = port;
+ let t = { pid = Forkhelpers.nopid; fd = data_out; host = host; port = port;
connected_time = Unix.gettimeofday (); unique_id = unique_id;
logfile = "" } in
let result = Forkhelpers.with_logfile_fd "stunnel"
Forkhelpers.Dup2(data_in, Unix.stdout);
Forkhelpers.Dup2(logfd, Unix.stderr) ] in
let fds_needed = [ Unix.stdin; Unix.stdout; Unix.stderr; config_out ] in
- let args = [ "-fd"; string_of_int (Unixext.int_of_file_descr config_out) ] in
+ let args = [ "-fd"; config_out_uuid ] in
if use_external_fd_wrapper then begin
- let cmdline = Printf.sprintf "Using commandline: %s\n" (String.concat " " (Forkhelpers.close_and_exec_cmdline fds_needed path args)) in
+ let cmdline = Printf.sprintf "Using commandline: %s\n" (String.concat " " (path::args)) in
write_to_log cmdline;
end;
t.pid <-
- (if use_external_fd_wrapper
- (* Run thread-safe external wrapper *)
- then Forkhelpers.safe_close_and_exec fdops fds_needed path args
- (* or do it ourselves (safe if there are no threads) *)
- else Forkhelpers.fork_and_exec ~pre_exec:
- (fun _ ->
- List.iter Forkhelpers.do_fd_operation fdops;
- Unixext.close_all_fds_except fds_needed)
- (path::args) );
+ if use_external_fd_wrapper
+ then Forkhelpers.safe_close_and_exec (Some data_in) (Some data_in) (Some logfd) [(config_out_uuid, config_out)] path args
+ else Forkhelpers.fork_and_exec ~pre_exec:
+ (fun _ ->
+ List.iter Forkhelpers.do_fd_operation fdops;
+ Unixext.close_all_fds_except fds_needed)
+ (path::args);
List.iter close [ data_in; config_out; ];
(* Make sure we close config_in eventually *)
finally
(fun () ->
- let pidmsg = Printf.sprintf "stunnel has pid: %d\n" t.pid in
+ let pidmsg = Printf.sprintf "stunnel has pidty: %s\n" (Forkhelpers.string_of_pidty t.pid) in
write_to_log pidmsg;
let config = config_file verify_cert extended_diagnosis host port in
val init_stunnel_path : unit -> unit
(** Represents an active stunnel connection *)
-type t = { mutable pid: int;
+type t = { mutable pid: Forkhelpers.pidty;
fd: Unix.file_descr;
host: string;
port: int;
projects / xcp / xen-api-libs.git / commitdiff