WARNING - OLD ARCHIVES

This is an archived copy of the Xen.org mailing list, which we have preserved to ensure that existing links to archives are not broken. The live archive, which contains the latest emails, can be found at http://lists.xen.org/
   
 
 
Xen 
 
Home Products Support Community News
 
   
 

xen-api

[Xen-API] [PATCH 1 of 6] CA-33440: add a single-threaded fork/exec daemo

To: xen-api@xxxxxxxxxxxxxxxxxxx
Subject: [Xen-API] [PATCH 1 of 6] CA-33440: add a single-threaded fork/exec daemon to fork/exec on behalf of xapi
From: David Scott <dave.scott@xxxxxxxxxxxxx>
Date: Fri, 18 Dec 2009 20:51:13 +0000
Delivery-date: Fri, 18 Dec 2009 12:51:35 -0800
Envelope-to: www-data@xxxxxxxxxxxxxxxxxxx
In-reply-to: <patchbomb.1261169472@xxxxxxxxxxxxxxxxxxxx>
List-help: <mailto:xen-api-request@lists.xensource.com?subject=help>
List-id: Discussion of API issues surrounding Xen <xen-api.lists.xensource.com>
List-post: <mailto:xen-api@lists.xensource.com>
List-subscribe: <http://lists.xensource.com/mailman/listinfo/xen-api>, <mailto:xen-api-request@lists.xensource.com?subject=subscribe>
List-unsubscribe: <http://lists.xensource.com/mailman/listinfo/xen-api>, <mailto:xen-api-request@lists.xensource.com?subject=unsubscribe>
Sender: xen-api-bounces@xxxxxxxxxxxxxxxxxxx
# 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 


Attachment: xen-api-libs.hg-6.patch
Description: Text Data

_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api