From: David Scott Date: Mon, 26 Oct 2009 16:32:15 +0000 (+0000) Subject: [refactoring] Move stunnel from xen-api.hg to xen-api-libs.hg X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=1a6e2c1873c5ce758d2c12bc1766cf21de2a9541;p=xcp%2Fxen-api-libs.git [refactoring] Move stunnel from xen-api.hg to xen-api-libs.hg Signed-off-by: Thomas Gazagnaire --- diff --git a/stunnel/META.in b/stunnel/META.in index c035902..5b38b05 100644 --- a/stunnel/META.in +++ b/stunnel/META.in @@ -1,5 +1,5 @@ version = "@VERSION@" description = "Secure Tunneling" -requires = "uuid,unix,stdext,log" +requires = "unix,stdext,log" archive(byte) = "stunnel.cma" archive(native) = "stunnel.cmxa" diff --git a/stunnel/Makefile b/stunnel/Makefile index 29d553d..f160f1b 100644 --- a/stunnel/Makefile +++ b/stunnel/Makefile @@ -5,6 +5,7 @@ OCAMLOPT = ocamlopt LDFLAGS = -cclib -L./ +DESTDIR ?= / VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0) OCAMLOPTFLAGS = -g -dtypes @@ -16,8 +17,6 @@ OBJS = stunnel stunnel_cache INTF = $(foreach obj, $(OBJS),$(obj).cmi) LIBS = stunnel.cma stunnel.cmxa -DOCDIR = /myrepos/xen-api-libs.hg/doc - all: $(INTF) $(LIBS) $(PROGRAMS) bins: $(PROGRAMS) @@ -31,13 +30,13 @@ stunnel.cma: $(foreach obj,$(OBJS),$(obj).cmo) $(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo) %.cmo: %.ml - $(OCAMLC) -c -I ../stdext -I ../uuid -I ../log -o $@ $< + $(OCAMLC) -c -I ../stdext -I ../log -o $@ $< %.cmi: %.mli - $(OCAMLC) -c -I ../stdext -I ../uuid -o $@ $< + $(OCAMLC) -c -o $@ $< %.cmx: %.ml - $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -I ../stdext -I ../uuid -I ../log -o $@ $< + $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -I ../stdext -I ../log -o $@ $< %.o: %.c $(CC) $(CFLAGS) -c -o $@ $< @@ -46,18 +45,12 @@ META: META.in sed 's/@VERSION@/$(VERSION)/g' < $< > $@ .PHONY: install -install: path = $(DESTDIR)$(shell ocamlfind printconf destdir) install: $(LIBS) META - mkdir -p $(path) - ocamlfind install -destdir $(path) -ldconf ignore stunnel META $(INTF) $(LIBS) *.a *.cmx + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore stunnel META $(INTF) $(LIBS) *.a *.cmx .PHONY: uninstall uninstall: ocamlfind remove stunnel -.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) + rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) \ No newline at end of file diff --git a/stunnel/stunnel.ml b/stunnel/stunnel.ml index 249365d..c1191d9 100644 --- a/stunnel/stunnel.ml +++ b/stunnel/stunnel.ml @@ -23,13 +23,11 @@ exception Stunnel_verify_error of string let certificate_path = "/etc/stunnel/certs" let crl_path = "/etc/stunnel/crls" -let verify_certificates_ctrl = "/var/xapi/verify_certificates" let use_new_stunnel = ref false 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") @@ -58,56 +56,7 @@ let stunnel_path() = | Some p -> p | None -> raise Stunnel_binary_missing -module Unsafe = struct - (** These functions are not safe in a multithreaded program *) - - (* 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. *) - let fork_and_exec ?(pre_exec=fun () -> ()) ?env (cmdline: string list) = - let args = Array.of_list cmdline in - let argv0 = List.hd cmdline in - let pid = Unix.fork () in - if pid = 0 then begin - try - pre_exec (); - (* CA-18955: xapi now runs with priority -3. We then set his sons priority to 0. *) - ignore_int (Unix.nice (-(Unix.nice 0))); - ignore_int (Unix.setsid ()); - match env with - | None -> Unix.execv argv0 args - | Some env -> Unix.execve argv0 args env - with _ -> exit 1 - end else pid - - (** File descriptor operations to be performed after a fork. - These are all safe in the presence of threads *) - type fd_operation = - | Dup2 of Unix.file_descr * Unix.file_descr - | Close of Unix.file_descr - - let do_fd_operation = function - | Dup2(a, b) -> Unix.dup2 a b - | Close a -> Unix.close a -end - -type pid = - | StdFork of int (** we forked and exec'ed. This is the pid *) - | FEFork of Forkhelpers.pidty (** the forkhelpers module did it for us. *) - | Nopid - -let string_of_pid = function - | StdFork x -> Printf.sprintf "(StdFork %d)" x - | FEFork x -> Forkhelpers.string_of_pidty x - | Nopid -> "None" - -let getpid ty = - match ty with - | StdFork pid -> pid - | FEFork pid -> Forkhelpers.getpid pid - | Nopid -> failwith "No pid!" - -type t = { mutable pid: pid; fd: Unix.file_descr; host: string; port: int; +type t = { mutable pid: int; fd: Unix.file_descr; host: string; port: int; connected_time: float; unique_id: int option; mutable logfile: string; @@ -130,29 +79,9 @@ let config_file verify_cert extended_diagnosis host port = let ignore_exn f x = try f x with _ -> () -let rec disconnect ?(wait = true) ?(force = false) x = +let disconnect x = List.iter (ignore_exn Unix.close) [ x.fd ]; - let waiter, pid = match x.pid with - | FEFork pid -> - (fun () -> - (if wait then Forkhelpers.waitpid - else Forkhelpers.waitpid_nohang) pid), - Forkhelpers.getpid pid - | StdFork pid -> - (fun () -> - (if wait then Unix.waitpid [] - else Unix.waitpid [Unix.WNOHANG]) pid), - pid in - let res = - try waiter () - with Unix.Unix_error (Unix.ECHILD, _, _) -> pid, Unix.WEXITED 0 in - match res with - | 0, _ when force -> - (try Unix.kill pid Sys.sigkill - with Unix.Unix_error (Unix.ESRCH, _, _) ->()); - disconnect ~wait:wait ~force:force x - | _ -> () - + ignore_exn Forkhelpers.waitpid 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. @@ -160,83 +89,111 @@ let rec disconnect ?(wait = true) ?(force = false) x = 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 = 0; 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 = [ + Forkhelpers.Dup2(data_in, Unix.stdin); + Forkhelpers.Dup2(data_in, Unix.stdout); + Forkhelpers.Dup2(logfd, Unix.stderr) + ] in + 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 + else + Forkhelpers.fork_and_exec ~pre_exec:(fun _ -> + List.iter Forkhelpers.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 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 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 + (* 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; + 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 + [ Forkhelpers.Dup2(data_in, Unix.stdin); + 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 + 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 + write_to_log cmdline; + end; t.pid <- - 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; + (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) ); + List.iter close [ data_in; config_out; ]; (* Make sure we close config_in eventually *) - 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 *) + finally + (fun () -> + + let pidmsg = Printf.sprintf "stunnel has pid: %d\n" 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; match result with | Forkhelpers.Success(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 ^ "]"); + if extended_diagnosis then + begin + write_to_log "success"; + t.logfile <- log + end + else + write_to_log ("success: Log from stunnel: [" ^ log ^ "]"); t | Forkhelpers.Failure(log, exn) -> - write_to_log ("stunnel abort: Log from stunnel: [" ^ log ^ "]"); + write_to_log ("failed: Log from stunnel: [" ^ log ^ "]"); disconnect t; raise exn @@ -255,21 +212,10 @@ let rec retry f = function @param extended_diagnosis If true, the stunnel log file will not be deleted. Instead, it is the caller's responsibility to delete it. This allows the caller to use diagnose_failure below if stunnel fails. *) -let connect - ?unique_id - ?use_external_fd_wrapper - ?write_to_log - ?verify_cert - ?(extended_diagnosis=false) - host - port = - let _verify_cert = match verify_cert with - | Some x -> x - | 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 connect ?unique_id ?use_external_fd_wrapper ?write_to_log + ?(verify_cert=false) ?(extended_diagnosis=false) host port = + let connect = if !use_new_stunnel then attempt_one_connect_new else attempt_one_connect in + retry (fun () -> 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 @@ -302,19 +248,14 @@ let check_error s line = let diagnose_failure st_proc = let check_line line = - !stunnel_logger line; + Printf.eprintf "stunnel_failure: %s\n" line; check_verify_error line; - check_error "Connection refused" line; + check_error "Connection refused" line; check_error "No host resolved" line; - check_error "No route to host" line; - 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. - *) + 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)) let test host port = let counter = ref 0 in diff --git a/stunnel/stunnel.mli b/stunnel/stunnel.mli index 570fb6b..4251bc6 100644 --- a/stunnel/stunnel.mli +++ b/stunnel/stunnel.mli @@ -22,15 +22,8 @@ val crl_path : string val use_new_stunnel : bool ref val init_stunnel_path : unit -> unit -type pid = - | StdFork of int (** we forked and exec'ed. This is the pid *) - | FEFork of Forkhelpers.pidty (** the forkhelpers module did it for us. *) - | Nopid - -val getpid: pid -> int - (** Represents an active stunnel connection *) -type t = { mutable pid: pid; +type t = { mutable pid: int; fd: Unix.file_descr; host: string; port: int; @@ -53,7 +46,7 @@ val connect : string -> int -> t (** Disconnects from stunnel and cleans up *) -val disconnect : ?wait:bool -> ?force:bool -> t -> unit +val disconnect : t -> unit val diagnose_failure : t -> unit