From: Jon Ludlam Date: Fri, 18 Dec 2009 20:48:33 +0000 (+0000) Subject: CA-33440: add a single-threaded fork/exec daemon to fork/exec on behalf of xapi. X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=b6cb3ed5080ddc66662c74d7cb7a2dc6c8123bce;p=xcp%2Fxen-api-libs.git CA-33440: add a single-threaded fork/exec daemon to fork/exec on behalf of xapi. 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 Acked-by: David Scott --- diff --git a/Makefile.in b/Makefile.in index 839b9e7..3853f2c 100644 --- a/Makefile.in +++ b/Makefile.in @@ -8,6 +8,9 @@ HAVE_TYPECONV = @OCAML_PKG_type_conv@ .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 @@ -15,9 +18,7 @@ all: $(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 @@ -164,6 +165,7 @@ clean: make -C close-and-exec clean make -C sexpr clean make -C doc clean + make -C forking_executioner clean cleanxen: $(MAKE) -C mmap clean diff --git a/forking_executioner/Makefile b/forking_executioner/Makefile index 7b6584e..4ae717e 100644 --- a/forking_executioner/Makefile +++ b/forking_executioner/Makefile @@ -7,7 +7,6 @@ OCAMLOPT = ocamlopt 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 @@ -31,10 +30,10 @@ bins: $(PROGRAMS) 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 $@ $< @@ -54,10 +53,8 @@ install: .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: @@ -65,7 +62,6 @@ uninstall: .PHONY: binuninstall binuninstall: rm -f $(DESTDIR)$(LIBEXEC)$(PROGRAMS) - rm -f $(DESTDIR)$(INIT_D)/fe .PHONY: doc doc: diff --git a/forking_executioner/child.ml b/forking_executioner/child.ml index c9006f2..14a3935 100644 --- a/forking_executioner/child.ml +++ b/forking_executioner/child.ml @@ -18,10 +18,6 @@ open Fe_debug 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 @@ -91,6 +87,8 @@ let run state comms_sock fd_sock fd_sock_path = in try + dbuffer := Buffer.create 500; + debug "Started: state.cmdargs = [%s]" (String.concat ";" (state.cmdargs)); debug "Started: state.env = [%s]" (String.concat ";" (state.env)); @@ -133,9 +131,6 @@ let run state comms_sock fd_sock fd_sock_path = (* 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 @@ -143,25 +138,10 @@ let run state comms_sock fd_sock fd_sock_path = 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; @@ -178,6 +158,5 @@ let run state comms_sock fd_sock fd_sock_path = | e -> debug "Caught unexpected exception: %s" (Printexc.to_string e); write_log (); - Unixext.unlink_safe fd_sock_path; exit 1 diff --git a/forking_executioner/fe_debug.ml b/forking_executioner/fe_debug.ml index a34e920..808f916 100644 --- a/forking_executioner/fe_debug.ml +++ b/forking_executioner/fe_debug.ml @@ -1,6 +1,6 @@ let log_path = "/var/log/fe.log" -let debug_log = ref [] +let dbuffer = ref (Buffer.create 1) let gettimestring () = let time = Unix.gettimeofday () in @@ -11,11 +11,13 @@ let gettimestring () = 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 diff --git a/forking_executioner/fe_main.ml b/forking_executioner/fe_main.ml index 5a5f149..e93aab9 100644 --- a/forking_executioner/fe_main.ml +++ b/forking_executioner/fe_main.ml @@ -1,7 +1,3 @@ - -(** 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 = @@ -43,26 +39,11 @@ 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 diff --git a/stdext/META.in b/stdext/META.in index 3f595bf..409c726 100644 --- a/stdext/META.in +++ b/stdext/META.in @@ -1,5 +1,5 @@ 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" diff --git a/stdext/Makefile b/stdext/Makefile index 3aef421..29380ef 100644 --- a/stdext/Makefile +++ b/stdext/Makefile @@ -15,12 +15,14 @@ OCAMLABI := $(OCAMLLOC) 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 @@ -59,8 +61,14 @@ querycd: querycd.cmo 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 $@ $< @@ -77,14 +85,23 @@ forkhelpers.cmi: forkhelpers.mli 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 $@ $< diff --git a/stdext/fecomms.ml b/stdext/fecomms.ml index bbe94e0..684a26b 100644 --- a/stdext/fecomms.ml +++ b/stdext/fecomms.ml @@ -4,7 +4,6 @@ let open_unix_domain_sock () = 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); diff --git a/stdext/forkhelpers.ml b/stdext/forkhelpers.ml index 931fdad..a5adf14 100644 --- a/stdext/forkhelpers.ml +++ b/stdext/forkhelpers.ml @@ -23,6 +23,19 @@ 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 *) @@ -56,7 +69,7 @@ let fork_and_exec ?(pre_exec=fun () -> ()) ?env (cmdline: string list) = | 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 *) @@ -68,21 +81,57 @@ let do_fd_operation = function | 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 @@ -113,42 +162,90 @@ let with_dev_null_read f = Unixext.with_file "/dev/null" [ Unix.O_RDONLY ] 0o0 f 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 + diff --git a/stdext/forkhelpers.mli b/stdext/forkhelpers.mli index c02774f..f9b39f1 100644 --- a/stdext/forkhelpers.mli +++ b/stdext/forkhelpers.mli @@ -26,6 +26,12 @@ exception Subprocess_failed of int 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 @@ -43,11 +49,11 @@ val do_fd_operation : fd_operation -> unit (** 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 @@ -62,6 +68,10 @@ val with_dev_null_read : (Unix.file_descr -> 'a) -> 'a*) (** 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 diff --git a/stdext/gzip.ml b/stdext/gzip.ml index d34234b..8182869 100644 --- a/stdext/gzip.ml +++ b/stdext/gzip.ml @@ -44,20 +44,18 @@ let go (mode: zcat_mode) (input: input_type) fd f = (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) @@ -69,7 +67,7 @@ let go (mode: zcat_mode) (input: input_type) fd f = 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) diff --git a/stdext/sha1sum.ml b/stdext/sha1sum.ml index dd40162..5b1f1ee 100644 --- a/stdext/sha1sum.ml +++ b/stdext/sha1sum.ml @@ -38,11 +38,7 @@ let sha1sum f = 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; @@ -61,12 +57,7 @@ let sha1sum f = 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) diff --git a/stdext/unixext.ml b/stdext/unixext.ml index e1a3734..b80287d 100644 --- a/stdext/unixext.ml +++ b/stdext/unixext.ml @@ -485,27 +485,6 @@ let close_all_fds_except (fds: Unix.file_descr list) = 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 = @@ -676,3 +655,6 @@ end 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" diff --git a/stdext/unixext.mli b/stdext/unixext.mli index 8008bde..4be933e 100644 --- a/stdext/unixext.mli +++ b/stdext/unixext.mli @@ -86,7 +86,6 @@ external get_max_fd : unit -> int = "stub_unixext_get_max_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 @@ -111,3 +110,6 @@ end 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" diff --git a/stdext/unixext_stubs.c b/stdext/unixext_stubs.c index cd8733f..1600537 100644 --- a/stdext/unixext_stubs.c +++ b/stdext/unixext_stubs.c @@ -16,6 +16,7 @@ #include #include #include +#include #include #include /* needed for _SC_OPEN_MAX */ #include /* snprintf */ @@ -267,3 +268,138 @@ CAMLprim value stub_fdset_is_empty(value set) 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(ret0) { + 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); +} diff --git a/stunnel/META.in b/stunnel/META.in index 5b38b05..c035902 100644 --- a/stunnel/META.in +++ b/stunnel/META.in @@ -1,5 +1,5 @@ version = "@VERSION@" description = "Secure Tunneling" -requires = "unix,stdext,log" +requires = "uuid,unix,stdext,log" archive(byte) = "stunnel.cma" archive(native) = "stunnel.cmxa" diff --git a/stunnel/Makefile b/stunnel/Makefile index 66665aa..29d553d 100644 --- a/stunnel/Makefile +++ b/stunnel/Makefile @@ -31,13 +31,13 @@ stunnel.cma: $(foreach obj,$(OBJS),$(obj).cmo) $(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 $@ $< @@ -58,6 +58,6 @@ uninstall: .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) diff --git a/stunnel/stunnel.ml b/stunnel/stunnel.ml index c1191d9..0df7c60 100644 --- a/stunnel/stunnel.ml +++ b/stunnel/stunnel.ml @@ -56,7 +56,8 @@ let stunnel_path() = | 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; @@ -81,7 +82,7 @@ let ignore_exn f x = try f x with _ -> () 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. @@ -94,7 +95,7 @@ let attempt_one_connect_new ?unique_id ?(use_external_fd_wrapper = true) ?(write 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 @@ -107,12 +108,12 @@ let attempt_one_connect_new ?unique_id ?(use_external_fd_wrapper = true) ?(write 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 @@ -131,12 +132,13 @@ let attempt_one_connect ?unique_id ?(use_external_fd_wrapper = true) ?(write_to_ 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" @@ -148,27 +150,25 @@ let attempt_one_connect ?unique_id ?(use_external_fd_wrapper = true) ?(write_to_ 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 diff --git a/stunnel/stunnel.mli b/stunnel/stunnel.mli index 4251bc6..a82afb6 100644 --- a/stunnel/stunnel.mli +++ b/stunnel/stunnel.mli @@ -23,7 +23,7 @@ val use_new_stunnel : bool ref 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;