# HG changeset patch
# User Jon Ludlam <Jonathan.Ludlam@xxxxxxxxxxxxx>
# Date 1261169313 0
# Node ID 5861a396a46c196844dd7d4cb7d35df0e62a6a0c
# Parent 5f4dcbe779847ef4ac943286bd628dbdc40dc927
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 <Jonathan.Ludlam@xxxxxxxxxxxxx>
Acked-by: David Scott <dave.scott@xxxxxxxxxxxxx>
diff -r 5f4dcbe77984 -r 5861a396a46c Makefile.in
--- a/Makefile.in Mon Dec 14 17:31:52 2009 +0000
+++ b/Makefile.in Fri Dec 18 20:48:33 2009 +0000
@@ -8,6 +8,9 @@
.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 @@
$(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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c forking_executioner/META.in
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/forking_executioner/META.in Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,5 @@
+version = "@VERSION@"
+description = "forking executioner script"
+requires = "unix,stdext"
+archive(byte) = "felib.cma"
+archive(native) = "felib.cmxa"
diff -r 5f4dcbe77984 -r 5861a396a46c forking_executioner/Makefile
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/forking_executioner/Makefile Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,70 @@
+IPROG=install -m 755 -o root -g root
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+LIBEXEC = "/opt/xensource/libexec"
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+
+OBJS =
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS =
+
+PROGRAMS = fe
+
+DOCDIR = /myrepos/xen-api-libs.hg/doc
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+test_forker: test_forker.cmx
+ $(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 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 $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -I ../log -I ../uuid -I ../stdext -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../log -I ../uuid -c -I ../stdext -o $@
$<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install:
+
+.PHONY: bininstall
+bininstall: path = $(DESTDIR)$(LIBEXEC)
+bininstall: all
+ mkdir -p $(path)
+ $(IPROG) $(PROGRAMS) $(path)
+
+.PHONY: uninstall
+uninstall:
+
+.PHONY: binuninstall
+binuninstall:
+ rm -f $(DESTDIR)$(LIBEXEC)$(PROGRAMS)
+
+.PHONY: doc
+doc:
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS)
$(PROGRAMS)
diff -r 5f4dcbe77984 -r 5861a396a46c forking_executioner/child.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/forking_executioner/child.ml Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,162 @@
+open Stringext
+
+let debug (fmt : ('a, unit, string, unit) format4) = (Printf.kprintf (fun s ->
Printf.fprintf stderr "%s\n" s) fmt)
+
+exception Cancelled
+
+type state_t = {
+ cmdargs : string list;
+ env : string list;
+ id_to_fd_map : (string * int option) list;
+ ids_received : (string * Unix.file_descr) list;
+ fd_sock2 : Unix.file_descr option;
+ finished : bool;
+}
+
+open Fe_debug
+
+let handle_fd_sock fd_sock state =
+ try
+ let (newfd,buffer) = Fecomms.receive_named_fd fd_sock in
+ let dest_fd = List.assoc buffer state.id_to_fd_map in
+ let fd = begin
+ match dest_fd with
+ | Some d ->
+ debug "Received fd named: %s - duping to %d (from %d)" buffer d
(Unixext.int_of_file_descr newfd);
+ let d = Unixext.file_descr_of_int d in
+ begin
+ if d = newfd
+ then ()
+ else begin
+ Unix.dup2 newfd d;
+ Unix.close newfd;
+ end
+ end;
+ d
+ | None ->
+ debug "Received fd named: %s (%d)" buffer
(Unixext.int_of_file_descr newfd);
+ newfd
+ end in
+ {state with ids_received = (buffer,fd) :: state.ids_received}
+ with Fecomms.Connection_closed ->
+ {state with fd_sock2 = None}
+
+let handle_comms_sock comms_sock state =
+ let call = Fecomms.read_raw_rpc comms_sock in
+ match call with
+ | Fe.Cancel -> debug "Cancel"; raise Cancelled
+ | Fe.Exec -> debug "Exec"; {state with finished=true;}
+ | _ ->
+ debug "Ignoring unknown command";
+ state
+
+let handle_comms_no_fd_sock2 comms_sock fd_sock state =
+ debug "Selecting in handle_comms_no_fd_sock2";
+ let (ready,_,_) = Unix.select [comms_sock; fd_sock] [] [] (-1.0) in
+ debug "Done";
+ if List.mem fd_sock ready then begin
+ debug "fd sock";
+ let fd_sock2,_ = Unix.accept fd_sock in
+ {state with fd_sock2=Some fd_sock2}
+ end else begin
+ debug "comms sock";
+ handle_comms_sock comms_sock state
+ end
+
+let handle_comms_with_fd_sock2 comms_sock fd_sock fd_sock2 state =
+ debug "Selecting in handle_comms_with_fd_sock2";
+ let (ready,_,_) = Unix.select [comms_sock; fd_sock2] [] [] (-1.0) in
+ debug "Done";
+ if List.mem fd_sock2 ready then begin
+ debug "fd sock2";
+ handle_fd_sock fd_sock2 state
+ end else begin
+ debug "comms sock";
+ handle_comms_sock comms_sock state
+ end
+
+let handle_comms comms_sock fd_sock state =
+ match state.fd_sock2 with
+ | None -> handle_comms_no_fd_sock2 comms_sock fd_sock state
+ | Some x -> handle_comms_with_fd_sock2 comms_sock fd_sock x state
+
+let run state comms_sock fd_sock fd_sock_path =
+ let rec inner state =
+ let state = handle_comms comms_sock fd_sock state in
+ if state.finished then state else inner state
+ in
+
+ try
+ dbuffer := Buffer.create 500;
+
+ debug "Started: state.cmdargs = [%s]" (String.concat ";" (state.cmdargs));
+ debug "Started: state.env = [%s]" (String.concat ";" (state.env));
+
+ let fd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o0 in
+ Unix.dup2 fd Unix.stdin;
+ Unix.dup2 fd Unix.stdout;
+ Unix.dup2 fd Unix.stderr;
+
+ if fd<>Unix.stdin && fd<>Unix.stdout && fd<>Unix.stderr then Unix.close fd;
+
+ let state = inner state in
+
+ debug "Finished...";
+ Unix.close fd_sock;
+ (match state.fd_sock2 with Some x -> Unix.close x | None -> ());
+
+ Unixext.unlink_safe fd_sock_path;
+
+ (* Finally, replace placeholder uuids in the commandline arguments
+ to be the string representation of the fd (where we don't care what
+ fd it ends up being) *)
+ let args = List.map (fun arg ->
+ try
+ let (id_received,fd) = List.find (fun (id_received,fd) ->
String.endswith id_received arg) state.ids_received in
+ let stem = String.sub arg 0 (String.length arg - String.length
id_received) in
+ stem ^ (string_of_int (Unixext.int_of_file_descr fd));
+ with _ -> arg) state.cmdargs in
+
+ debug "Args after replacement = [%s]" (String.concat ";" args);
+
+ let fds = List.map snd state.ids_received in
+
+ debug "I've received the following fds: [%s]\n"
+ (String.concat ";" (List.map (fun fd -> string_of_int
(Unixext.int_of_file_descr fd)) fds));
+
+ let result = Unix.fork () in
+
+ if result=0 then begin
+ (* child *)
+ (* 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);
+
+ (* And exec *)
+ Unix.execve (List.hd args) (Array.of_list args) (Array.of_list state.env)
+ end else begin
+ Fecomms.write_raw_rpc comms_sock (Fe.Execed result);
+
+ List.iter (fun fd -> Unix.close fd) fds;
+ let (pid,status) = Unix.waitpid [] result in
+ let pr = match status with
+ | 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;
+ Unix.close comms_sock;
+ exit 0;
+ end
+ with
+ | Cancelled ->
+ debug "Cancelling";
+ Unix.close comms_sock;
+ Unix.close fd_sock;
+ Unixext.unlink_safe fd_sock_path;
+ exit 0;
+ | e ->
+ debug "Caught unexpected exception: %s" (Printexc.to_string e);
+ write_log ();
+ exit 1
+
diff -r 5f4dcbe77984 -r 5861a396a46c forking_executioner/fe_debug.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/forking_executioner/fe_debug.ml Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,23 @@
+let log_path = "/var/log/fe.log"
+
+let dbuffer = ref (Buffer.create 1)
+
+let gettimestring () =
+ let time = Unix.gettimeofday () in
+ let tm = Unix.gmtime time in
+ let msec = time -. (floor time) in
+ Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 +
tm.Unix.tm_year)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+ (int_of_float (1000.0 *. msec))
+
+let reset () = dbuffer := Buffer.create 100
+
+let debug (fmt : ('a, unit, string, unit) format4) =
+ Printf.kprintf (fun s -> ignore(Printf.bprintf !dbuffer "%s|%d|%s\n"
(gettimestring ()) (Unix.getpid ()) s)) fmt
+
+let write_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 -r 5f4dcbe77984 -r 5861a396a46c forking_executioner/fe_main.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/forking_executioner/fe_main.ml Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,68 @@
+open Fe_debug
+
+let setup sock cmdargs id_to_fd_map env =
+ let fd_sock_path = Printf.sprintf "/var/xapi/forker/fd_%s"
+ (Uuid.to_string (Uuid.make_uuid ())) in
+ let fd_sock = Fecomms.open_unix_domain_sock () in
+ Unixext.unlink_safe fd_sock_path;
+ debug "About to bind to %s" fd_sock_path;
+ Unix.bind fd_sock (Unix.ADDR_UNIX fd_sock_path);
+ Unix.listen fd_sock 5;
+ debug "bound, listening";
+ let result = Unix.fork () in
+ if result=0
+ then begin
+ debug "Child here!";
+ let result2 = Unix.fork () in
+ if result2=0 then begin
+ debug "Grandchild here!";
+ (* Grandchild *)
+ let state = {
+ Child.cmdargs=cmdargs;
+ env=env;
+ id_to_fd_map=id_to_fd_map;
+ ids_received=[];
+ fd_sock2=None;
+ finished=false;
+ } in
+ Child.run state sock fd_sock fd_sock_path
+ end else begin
+ (* Child *)
+ exit 0;
+ end
+ end else begin
+ (* Parent *)
+ debug "Waiting for process %d to exit" result;
+ ignore(Unix.waitpid [] result);
+ Unix.close fd_sock;
+ Some {Fe.fd_sock_path=fd_sock_path}
+ end
+
+let _ =
+ (* Unixext.daemonize ();*)
+ Sys.set_signal Sys.sigpipe (Sys.Signal_ignore);
+
+ let main_sock = Fecomms.open_unix_domain_sock_server "/var/xapi/forker/main"
in
+
+ while true do
+ try
+ let (sock,addr) = Unix.accept main_sock in
+ reset ();
+ let cmd = Fecomms.read_raw_rpc sock in
+ match cmd with
+ | Fe.Setup s ->
+ let result = setup sock s.Fe.cmdargs s.Fe.id_to_fd_map s.Fe.env in
+ (match result with
+ | Some response ->
+ Fecomms.write_raw_rpc sock (Fe.Setup_response response);
+ Unix.close sock;
+ | _ -> ())
+ | _ ->
+ debug "Ignoring invalid message";
+ Unix.close sock
+ with e ->
+ debug "Caught exception at top level: %s" (Printexc.to_string e);
+ done
+
+
+
diff -r 5f4dcbe77984 -r 5861a396a46c forking_executioner/test_forker.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/forking_executioner/test_forker.ml Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,49 @@
+
+let _ =
+ let die_at = int_of_string Sys.argv.(1) in
+ let sock = Fecomms.open_unix_domain_sock_client "/var/xapi/forker/main" in
+ let uuid = Uuid.to_string (Uuid.make_uuid ()) in
+ Printf.fprintf stderr "About to write raw rpc\n%!";
+ Fecomms.write_raw_rpc sock (Fe.Setup
{Fe.cmdargs=["/bin/fecho";"hello";"test"]; id_to_fd_map = [(uuid,Some
(Unixext.int_of_file_descr Unix.stdout))]; env=[]});
+ if die_at=1 then exit(1);
+ Printf.fprintf stderr "Done write raw rpc\n%!";
+ let response = Fecomms.read_raw_rpc sock in
+ if die_at=2 then exit(1);
+ Printf.fprintf stderr "Got response\n%!";
+ match response with
+ | Fe.Setup_response s ->
+ Printf.fprintf stderr "Got response: fd_sock_path=%s\n%!"
s.Fe.fd_sock_path;
+ let (rd,wr) = Unix.pipe () in
+ let fd_sock = Fecomms.open_unix_domain_sock_client s.Fe.fd_sock_path in
+ if die_at=3 then exit(1);
+ (try
+ Fecomms.send_named_fd fd_sock uuid wr;
+ with e ->
+ Printf.fprintf stderr "Failed to send named fd: %s%!"
(Printexc.to_string e));
+ if die_at=4 then exit(1);
+ Unix.close wr;
+ Unix.close fd_sock;
+ Fecomms.write_raw_rpc sock Fe.Exec;
+ if die_at=5 then exit(1);
+ (match Fecomms.read_raw_rpc sock with
+ | Fe.Execed pid ->
+ Printf.fprintf stderr "Got pid: %d\n%!" pid);
+ if die_at=6 then exit(1);
+ let buffer = Buffer.create 1000 in
+ let str = String.make 1000 '\000' in
+ let rec consume () =
+ let len = Unix.read rd str 0 (String.length str) in
+ if len=0
+ then ()
+ else
+ begin
+ Buffer.add_substring buffer str 0 len;
+ consume ()
+ end
+ in
+ consume ();
+ Printf.fprintf stderr "Received: %s\n%!" (Buffer.contents buffer);
+ match Fecomms.read_raw_rpc sock with
+ | Fe.Finished res ->
+ Printf.fprintf stderr "Got finished\n%!";
+
diff -r 5f4dcbe77984 -r 5861a396a46c stdext/META.in
--- a/stdext/META.in Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/META.in Fri Dec 18 20:48:33 2009 +0000
@@ -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 -r 5f4dcbe77984 -r 5861a396a46c stdext/Makefile
--- a/stdext/Makefile Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/Makefile Fri Dec 18 20:48:33 2009 +0000
@@ -15,12 +15,14 @@
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 @@
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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stdext/fe.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/fe.ml Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,24 @@
+
+type setup_cmd = {
+ cmdargs : string list;
+ env : string list;
+ id_to_fd_map : (string * int option) list }
+
+and setup_response = {
+ fd_sock_path : string }
+
+and process_result =
+ | WEXITED of int
+ | WSIGNALED of int
+ | WSTOPPED of int
+
+and ferpc =
+ | Setup of setup_cmd
+ | Setup_response of setup_response
+ | Cancel
+ | Exec
+ | Execed of int
+ | Finished of process_result
+ | Log_reopen
+with rpc
+
diff -r 5f4dcbe77984 -r 5861a396a46c stdext/fecomms.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/fecomms.ml Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,42 @@
+open Fe
+
+let open_unix_domain_sock () =
+ Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0
+
+let open_unix_domain_sock_server path =
+ Unixext.unlink_safe path;
+ let sock = open_unix_domain_sock () in
+ Unix.bind sock (Unix.ADDR_UNIX path);
+ Unix.listen sock 5;
+ sock
+
+let open_unix_domain_sock_client path =
+ let sock = open_unix_domain_sock () in
+ Unix.connect sock (Unix.ADDR_UNIX path);
+ sock
+
+let read_raw_rpc sock =
+ let buffer = String.make 12 '\000' in
+ Unixext.really_read sock buffer 0 12;
+ let len = int_of_string buffer in
+ let body = Unixext.really_read_string sock len in
+ ferpc_of_rpc (Jsonrpc.of_string body)
+
+let write_raw_rpc sock ferpc =
+ let body = Jsonrpc.to_string (rpc_of_ferpc ferpc) in
+ let len = String.length body in
+ let buffer = Printf.sprintf "%012d%s" len body in
+ Unixext.really_write_string sock buffer
+
+exception Connection_closed
+
+let receive_named_fd sock =
+ let buffer = String.make 36 '\000' in
+ let (len,from,newfd) = Unixext.recv_fd sock buffer 0 36 [] in
+ if len=0 then raise Connection_closed;
+ (newfd,buffer)
+
+let send_named_fd sock uuid fd =
+ ignore(Unixext.send_fd sock uuid 0 (String.length uuid) [] fd)
+
+
diff -r 5f4dcbe77984 -r 5861a396a46c stdext/fecomms.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/fecomms.mli Fri Dec 18 20:48:33 2009 +0000
@@ -0,0 +1,8 @@
+val open_unix_domain_sock : unit -> Unix.file_descr
+val open_unix_domain_sock_server : string -> Unix.file_descr
+val open_unix_domain_sock_client : string -> Unix.file_descr
+val read_raw_rpc : Unix.file_descr -> Fe.ferpc
+val write_raw_rpc : Unix.file_descr -> Fe.ferpc -> unit
+exception Connection_closed
+val receive_named_fd : Unix.file_descr -> Unix.file_descr * string
+val send_named_fd : Unix.file_descr -> string -> Unix.file_descr -> unit
diff -r 5f4dcbe77984 -r 5861a396a46c stdext/forkhelpers.ml
--- a/stdext/forkhelpers.ml Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/forkhelpers.ml Fri Dec 18 20:48:33 2009 +0000
@@ -22,6 +22,19 @@
(* XXX: this is a work in progress *)
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 @@
| 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 @@
| 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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stdext/forkhelpers.mli
--- a/stdext/forkhelpers.mli Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/forkhelpers.mli Fri Dec 18 20:48:33 2009 +0000
@@ -26,6 +26,12 @@
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 @@
(** 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 @@
(** 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 -r 5f4dcbe77984 -r 5861a396a46c stdext/gzip.ml
--- a/stdext/gzip.ml Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/gzip.ml Fri Dec 18 20:48:33 2009 +0000
@@ -44,20 +44,18 @@
(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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stdext/sha1sum.ml
--- a/stdext/sha1sum.ml Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/sha1sum.ml Fri Dec 18 20:48:33 2009 +0000
@@ -38,11 +38,7 @@
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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stdext/unixext.ml
--- a/stdext/unixext.ml Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/unixext.ml Fri Dec 18 20:48:33 2009 +0000
@@ -485,27 +485,6 @@
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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stdext/unixext.mli
--- a/stdext/unixext.mli Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/unixext.mli Fri Dec 18 20:48:33 2009 +0000
@@ -86,7 +86,6 @@
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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stdext/unixext_stubs.c
--- a/stdext/unixext_stubs.c Mon Dec 14 17:31:52 2009 +0000
+++ b/stdext/unixext_stubs.c Fri Dec 18 20:48:33 2009 +0000
@@ -16,6 +16,7 @@
#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 */
@@ -267,3 +268,138 @@
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);
+}
diff -r 5f4dcbe77984 -r 5861a396a46c stunnel/META.in
--- a/stunnel/META.in Mon Dec 14 17:31:52 2009 +0000
+++ b/stunnel/META.in Fri Dec 18 20:48:33 2009 +0000
@@ -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 -r 5f4dcbe77984 -r 5861a396a46c stunnel/Makefile
--- a/stunnel/Makefile Mon Dec 14 17:31:52 2009 +0000
+++ b/stunnel/Makefile Fri Dec 18 20:48:33 2009 +0000
@@ -31,13 +31,13 @@
$(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 @@
.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 -r 5f4dcbe77984 -r 5861a396a46c stunnel/stunnel.ml
--- a/stunnel/stunnel.ml Mon Dec 14 17:31:52 2009 +0000
+++ b/stunnel/stunnel.ml Fri Dec 18 20:48:33 2009 +0000
@@ -56,7 +56,8 @@
| 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 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 @@
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 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 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 @@
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 -r 5f4dcbe77984 -r 5861a396a46c stunnel/stunnel.mli
--- a/stunnel/stunnel.mli Mon Dec 14 17:31:52 2009 +0000
+++ b/stunnel/stunnel.mli Fri Dec 18 20:48:33 2009 +0000
@@ -23,7 +23,7 @@
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;
23 files changed, 814 insertions(+), 128 deletions(-)
Makefile.in | 8 -
forking_executioner/META.in | 5
forking_executioner/Makefile | 70 ++++++++++++
forking_executioner/child.ml | 162 +++++++++++++++++++++++++++++
forking_executioner/fe_debug.ml | 23 ++++
forking_executioner/fe_main.ml | 68 ++++++++++++
forking_executioner/test_forker.ml | 49 ++++++++
stdext/META.in | 2
stdext/Makefile | 25 +++-
stdext/fe.ml | 24 ++++
stdext/fecomms.ml | 42 +++++++
stdext/fecomms.mli | 8 +
stdext/forkhelpers.ml | 197 ++++++++++++++++++++++++++----------
stdext/forkhelpers.mli | 16 ++
stdext/gzip.ml | 16 +-
stdext/sha1sum.ml | 13 --
stdext/unixext.ml | 24 ----
stdext/unixext.mli | 4
stdext/unixext_stubs.c | 136 ++++++++++++++++++++++++
stunnel/META.in | 2
stunnel/Makefile | 8 -
stunnel/stunnel.ml | 38 +++---
stunnel/stunnel.mli | 2
xen-api-libs.hg-6.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home