# HG changeset patch # User Zheng Li # Date 1270027580 -3600 # Node ID 704a6cc45f4b32b67cf569c407bccc6b5b2fe83e # Parent 30faec648dfb17b876b9f97c678a177131be1558 Merge Stunnel.attempt_one_connect_new into Stunnel.attempt_one_connect and other minor improvements. Signed-off-by: Zheng Li 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