Signed-off-by: Zheng Li <dev@xxxxxxxx>
stunnel/stunnel.ml | 183 ++++++++++++++++++++-------------------------
1 files changed, 80 insertions(+), 103 deletions(-)
diff -r 30faec648dfb -r 704a6cc45f4b stunnel/stunnel.ml
--- a/stunnel/stunnel.ml Tue Mar 23 00:39:58 2010 +0000
+++ b/stunnel/stunnel.ml Wed Mar 31 10:26:20 2010 +0100
@@ -29,6 +29,7 @@
let new_stunnel_path = "/usr/sbin/stunnelng"
let cached_stunnel_path = ref None
+let stunnel_logger = ref ignore
let init_stunnel_path () =
try cached_stunnel_path := Some (Unix.getenv "XE_STUNNEL")
@@ -142,112 +143,83 @@
exception instead *)
exception Stunnel_initialisation_failed
-let attempt_one_connect_new ?unique_id ?(use_external_fd_wrapper = true)
?(write_to_log = fun _ -> ()) verify_cert extended_diagnosis host port =
- assert (not verify_cert); (* !!! Unimplemented *)
- 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 = Nopid; fd = data_out; host = host; port = port;
- connected_time = Unix.gettimeofday (); unique_id = unique_id;
- logfile = "" } in
- let to_close = ref [ data_in ] in
- let result = Forkhelpers.with_logfile_fd "stunnel" (fun logfd ->
- let fdops = [
- Unsafe.Dup2(data_in, Unix.stdin);
- Unsafe.Dup2(data_in, Unix.stdout);
- Unsafe.Dup2(logfd, Unix.stderr)
- ] in
- let fds_needed = [ Unix.stdin; Unix.stdout; Unix.stderr ] in
- t.pid <- (
- if use_external_fd_wrapper then
- FEFork (Forkhelpers.safe_close_and_exec (Some data_in) (Some data_in)
(Some logfd) [] (stunnel_path ()) args)
- else
- StdFork(Unsafe.fork_and_exec ~pre_exec:(fun _ ->
- List.iter Unsafe.do_fd_operation fdops;
- Unixext.close_all_fds_except fds_needed
-
- ) ((stunnel_path ()) :: args))
- );
- List.iter Unix.close [ data_in ];
- ) in
- List.iter Unix.close !to_close;
- match result with
- | Forkhelpers.Failure(log, exn) ->
- write_to_log ("failed: Log from stunnel: [" ^ log ^ "]");
- disconnect t;
- raise exn
- | Forkhelpers.Success(log, _) ->
- write_to_log ("success: Log from stunnel: [" ^ log ^ "]");
- t
(* Internal function which may throw Stunnel_initialisation_failed *)
-let attempt_one_connect ?unique_id ?(use_external_fd_wrapper = true)
?(write_to_log = fun _ -> ()) verify_cert extended_diagnosis host port =
- 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 = Nopid; fd = data_out; host = host; port = port;
- connected_time = Unix.gettimeofday (); unique_id = unique_id;
- logfile = "" } in
+let attempt_one_connect ?unique_id ?(use_external_fd_wrapper = true)
+ ?(write_to_log = fun _ -> ()) verify_cert extended_diagnosis host port =
+ let fds_needed = ref [ Unix.stdin; Unix.stdout; Unix.stderr ] in
+ let config_in, config_out, configs, args =
+ if !use_new_stunnel
+ then begin
+ assert (not verify_cert); (* !! Unimplemented *)
+ let args = [ "-m"; "client"; "-s"; "-"; "-d";
+ Printf.sprintf "%s:%d" host port ] in
+ None, None, [], (if extended_diagnosis then "-v" :: args else args)
+ end else begin
+ let config_out, config_in = Unix.pipe () in
+ let config_out_uuid = Uuid.to_string (Uuid.make_uuid ()) in
+ let config_out_fd =
+ string_of_int (Unixext.int_of_file_descr config_out) in
+ fds_needed := config_out :: !fds_needed;
+ Some config_in, Some config_out, [(config_out_uuid, config_out)],
+ ["-fd"; if use_external_fd_wrapper then config_out_uuid else
config_out_fd]
+ end in
+ let data_out,data_in = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ let t =
+ { pid = 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"
~delete:(not extended_diagnosis)
(fun logfd ->
let path = stunnel_path() in
let fdops =
- [ Unsafe.Dup2(data_in, Unix.stdin);
- Unsafe.Dup2(data_in, Unix.stdout);
- Unsafe.Dup2(logfd, Unix.stderr) ] in
- let fds_needed = [ Unix.stdin; Unix.stdout; Unix.stderr; config_out ] in
- let args_external = [ "-fd"; config_out_uuid ] in
- let args_internal = [ "-fd"; string_of_int
(Unixext.int_of_file_descr config_out) ] in
- if use_external_fd_wrapper then begin
- let cmdline = Printf.sprintf "Using commandline: %s\n" (String.concat
" " (path::args_external)) in
- write_to_log cmdline;
- end;
+ [ Unsafe.Dup2(data_in, Unix.stdin);
+ Unsafe.Dup2(data_in, Unix.stdout);
+ Unsafe.Dup2(logfd, Unix.stderr) ] in
t.pid <-
- if use_external_fd_wrapper
- then FEFork(Forkhelpers.safe_close_and_exec (Some data_in) (Some
data_in) (Some logfd) [(config_out_uuid, config_out)] path args_external)
- else StdFork(Unsafe.fork_and_exec ~pre_exec:
- (fun _ ->
- List.iter Unsafe.do_fd_operation fdops;
- Unixext.close_all_fds_except fds_needed)
- (path::args_internal));
- List.iter close [ data_in; config_out; ];
+ if use_external_fd_wrapper then begin
+ let cmdline = Printf.sprintf "Using commandline: %s\n"
(String.concat " " (path::args)) in
+ write_to_log cmdline;
+ FEFork(Forkhelpers.safe_close_and_exec
+ (Some data_in) (Some data_in) (Some logfd) configs path
args)
+ end else
+ StdFork(Unsafe.fork_and_exec
+ ~pre_exec:(fun _ ->
+ List.iter
Unsafe.do_fd_operation fdops;
+
Unixext.close_all_fds_except !fds_needed)
+ (path::args));
+ (match config_out with Some fd -> Unix.close fd | _ -> ());
+ Unix.close data_in;
(* Make sure we close config_in eventually *)
- finally
- (fun () ->
-
- let pidmsg = Printf.sprintf "stunnel has pidty: %s\n"
(string_of_pid t.pid) in
- write_to_log pidmsg;
-
- let config = config_file verify_cert extended_diagnosis host port in
- (* Catch the occasional initialisation failure of stunnel: *)
- try
- let n = Unix.write config_in config 0 (String.length config) in
- if n < String.length config then raise
Stunnel_initialisation_failed
- with Unix.Unix_error(err, fn, arg) ->
- write_to_log (Printf.sprintf "Caught Unix.Unix_error(%s, %s, %s);
raising Stunnel_initialisation_failed" (Unix.error_message err) fn arg);
- raise Stunnel_initialisation_failed)
- (fun () -> close config_in)) in
- (* Tidy up any remaining unclosed fds *)
- List.iter Unix.close !to_close;
+ finally
+ (fun () ->
+ let pidmsg = Printf.sprintf "stunnel has pidty: %s"
(string_of_pid t.pid) in
+ write_to_log pidmsg;
+ match config_in with
+ | Some fd -> begin
+ let config = config_file verify_cert extended_diagnosis
host port in
+ (* Catch the occasional initialisation failure of
stunnel: *)
+ try
+ let n = Unix.write fd config 0 (String.length config) in
+ if n < String.length config then raise
Stunnel_initialisation_failed
+ with Unix.Unix_error(err, fn, arg) ->
+ write_to_log (Printf.sprintf "Caught
Unix.Unix_error(%s, %s, %s); raising Stunnel_initialisation_failed"
(Unix.error_message err) fn arg);
+ raise Stunnel_initialisation_failed
+ end
+ | _ -> ())
+ (fun () -> match config_in with Some fd -> Unix.close fd | _ ->
assert false)) in
+ (* Tidy up any remaining unclosed fds *)
match result with
| Forkhelpers.Success(log, _) ->
- if extended_diagnosis then
- begin
- write_to_log "success";
- t.logfile <- log
- end
- else
- write_to_log ("success: Log from stunnel: [" ^ log ^ "]");
+ if extended_diagnosis then begin
+ write_to_log "stunnel start";
+ t.logfile <- log
+ end else
+ write_to_log ("stunnel start: Log from stunnel: [" ^ log ^ "]");
t
| Forkhelpers.Failure(log, exn) ->
- write_to_log ("failed: Log from stunnel: [" ^ log ^ "]");
+ write_to_log ("stunnel abort: Log from stunnel: [" ^ log ^ "]");
disconnect t;
raise exn
@@ -274,12 +246,13 @@
?(extended_diagnosis=false)
host
port =
- let connect = if !use_new_stunnel then attempt_one_connect_new else
attempt_one_connect in
let _verify_cert = match verify_cert with
| Some x -> x
- | None -> Sys.file_exists verify_certificates_ctrl
- in
- retry (fun () -> connect ?unique_id ?use_external_fd_wrapper
?write_to_log _verify_cert extended_diagnosis host port) 5
+ | None -> Sys.file_exists verify_certificates_ctrl in
+ let _ = match write_to_log with
+ | Some logger -> stunnel_logger := logger
+ | None -> () in
+ retry (fun () -> attempt_one_connect ?unique_id
?use_external_fd_wrapper ?write_to_log _verify_cert extended_diagnosis host
port) 5
let sub_after i s =
let len = String.length s in
@@ -312,14 +285,18 @@
let diagnose_failure st_proc =
let check_line line =
- Printf.eprintf "stunnel_failure: %s\n" line;
+ !stunnel_logger line;
check_verify_error line;
- check_error "Connection refused" line;
+ check_error "Connection refused" line;
check_error "No host resolved" line;
- check_error "Invalid argument" line;
- in
- Unixext.readfile_line check_line st_proc.logfile;
- raise (Stunnel_error (Unixext.read_whole_file_to_string st_proc.logfile))
+ check_error "Invalid argument" line in
+ Unixext.readfile_line check_line st_proc.logfile
+ (* If we reach here the whole stunnel log should have been gone through
+ (possibly printed/logged somewhere. No necessity to raise an exception,
+ since when this function being called, there is usually some exception
+ already existing in the caller's context, and it's not necessary always a
+ stunnel error.
+ *)
let test host port =
let counter = ref 0 in
xen-api-lib.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home