# 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;