From 0c0a13e49b3eedc8ea642e8382fabc38afd158ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Tue, 9 Nov 2021 19:32:53 +0100 Subject: [PATCH] Add ?cloexec:bool argument to wrapped Unix functions in Lwt_unix In the Lwt_unix module, add `?cloexec:bool` optional arguments to functions that create file descriptors (`dup`, `dup2`, `pipe`, `pipe_in`, `pipe_out`, `socket`, `socketpair`, `accept`, `accept_n`). The `?cloexec` argument is simply forwarded to the wrapped Unix function (with OCaml >= 4.05, see [ocaml/ocaml#650][650]), or emulated as best-effort with `Unix.set_close_on_exec` on older OCaml versions. Fix #327. Fix #847. See also #872. [650]: https://github.com/ocaml/ocaml/pull/650 --- CHANGES | 2 + src/unix/lwt_unix.cppo.ml | 110 +++++++++++++++++++++++++-------- src/unix/lwt_unix.cppo.mli | 27 +++++--- src/unix/unix_c/unix_accept4.c | 4 +- 4 files changed, 106 insertions(+), 37 deletions(-) diff --git a/CHANGES b/CHANGES index 6ce1602fbf..82600f4f13 100644 --- a/CHANGES +++ b/CHANGES @@ -37,6 +37,8 @@ * Support IPv6 (always) and PF_UNIX (with OCaml >= 4.14) socketpair on Windows (#870, #876, Antonin Décimo, David Allsopp). + * In the Lwt_unix module, add `?cloexec:bool` optional arguments to functions that create file descriptors (`dup`, `dup2`, `pipe`, `pipe_in`, `pipe_out`, `socket`, `socketpair`, `accept`, `accept_n`). The `?cloexec` argument is simply forwarded to the wrapped Unix function (with OCaml >= 4.05, see PR ocaml/ocaml#650), or emulated as best-effort with `Unix.set_close_on_exec` on older OCaml versions (#327, #847, #872, #901, Antonin Décimo). + ====== Misc ====== * Code quality improvement: remove an uneeded Obj.magic (#844, Benoit Montagu). diff --git a/src/unix/lwt_unix.cppo.ml b/src/unix/lwt_unix.cppo.ml index 4c59e26716..876a35ff60 100644 --- a/src/unix/lwt_unix.cppo.ml +++ b/src/unix/lwt_unix.cppo.ml @@ -1233,9 +1233,14 @@ let access name mode = | Operations on file descriptors | +-----------------------------------------------------------------+ *) -let dup ch = +let dup ?cloexec ch = check_descriptor ch; +#if OCAML_VERSION >= (4, 05, 0) + let fd = Unix.dup ?cloexec ch.fd in +#else let fd = Unix.dup ch.fd in + if cloexec = Some true then Unix.set_close_on_exec fd; +#endif { fd = fd; state = Opened; @@ -1252,9 +1257,14 @@ let dup ch = hooks_writable = Lwt_sequence.create (); } -let dup2 ch1 ch2 = +let dup2 ?cloexec ch1 ch2 = check_descriptor ch1; +#if OCAML_VERSION >= (4, 05, 0) + Unix.dup2 ?cloexec ch1.fd ch2.fd; +#else Unix.dup2 ch1.fd ch2.fd; + if cloexec = Some true then Unix.set_close_on_exec ch2.fd; +#endif ch2.set_flags <- ch1.set_flags; ch2.blocking <- ( if ch2.set_flags then @@ -1439,16 +1449,40 @@ let files_of_directory path = | Pipes and redirections | +-----------------------------------------------------------------+ *) -let pipe () = - let (out_fd, in_fd) = Unix.pipe() in +let pipe ?cloexec () = +#if OCAML_VERSION >= (4, 05, 0) + let (out_fd, in_fd) = Unix.pipe ?cloexec () in +#else + let (out_fd, in_fd) = Unix.pipe () in + if cloexec = Some true then begin + Unix.set_close_on_exec out_fd; + Unix.set_close_on_exec in_fd + end; +#endif (mk_ch ~blocking:Sys.win32 out_fd, mk_ch ~blocking:Sys.win32 in_fd) -let pipe_in () = - let (out_fd, in_fd) = Unix.pipe() in +let pipe_in ?cloexec () = +#if OCAML_VERSION >= (4, 05, 0) + let (out_fd, in_fd) = Unix.pipe ?cloexec () in +#else + let (out_fd, in_fd) = Unix.pipe () in + if cloexec = Some true then begin + Unix.set_close_on_exec out_fd; + Unix.set_close_on_exec in_fd + end; +#endif (mk_ch ~blocking:Sys.win32 out_fd, in_fd) -let pipe_out () = - let (out_fd, in_fd) = Unix.pipe() in +let pipe_out ?cloexec () = +#if OCAML_VERSION >= (4, 05, 0) + let (out_fd, in_fd) = Unix.pipe ?cloexec () in +#else + let (out_fd, in_fd) = Unix.pipe () in + if cloexec = Some true then begin + Unix.set_close_on_exec out_fd; + Unix.set_close_on_exec in_fd + end; +#endif (out_fd, mk_ch ~blocking:Sys.win32 in_fd) external mkfifo_job : string -> int -> unit job = "lwt_unix_mkfifo_job" @@ -1664,8 +1698,13 @@ type socket_type = type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int -let socket dom typ proto = +let socket ?cloexec dom typ proto = +#if OCAML_VERSION >= (4, 05, 0) + let s = Unix.socket ?cloexec dom typ proto in +#else let s = Unix.socket dom typ proto in + if cloexec = Some true then Unix.set_close_on_exec s; +#endif mk_ch ~blocking:false s type shutdown_command = @@ -1680,37 +1719,56 @@ let shutdown ch shutdown_command = external stub_socketpair : socket_domain -> socket_type -> int -> Unix.file_descr * Unix.file_descr = "lwt_unix_socketpair_stub" -let socketpair dom typ proto = +#if OCAML_VERSION >= (4, 05, 0) +let stub_socketpair ?cloexec dom typ proto = + let (s1, s2) = stub_socketpair dom typ proto in + if cloexec = Some true then begin + Unix.set_close_on_exec s1; + Unix.set_close_on_exec s2 + end; + (s1, s2) +#endif + +let socketpair ?cloexec dom typ proto = + let (s1, s2) = #if OCAML_VERSION >= (4, 14, 0) - let do_socketpair = - if Sys.win32 && (dom <> Unix.PF_UNIX) then stub_socketpair - else Unix.socketpair ?cloexec:None in + if Sys.win32 && (dom <> Unix.PF_UNIX) then + stub_socketpair ?cloexec dom typ proto + else Unix.socketpair ?cloexec dom typ proto in #elif OCAML_VERSION >= (4, 05, 0) - let do_socketpair = - if Sys.win32 then stub_socketpair - else Unix.socketpair ?cloexec:None in + if Sys.win32 then stub_socketpair ?cloexec dom typ proto + else Unix.socketpair ?cloexec dom typ proto in #else - let do_socketpair = if Sys.win32 then stub_socketpair else Unix.socketpair in + if Sys.win32 then stub_socketpair dom typ proto + else Unix.socketpair dom typ proto in + if cloexec = Some true then begin + Unix.set_close_on_exec s1; + Unix.set_close_on_exec s2 + end; #endif - let (s1, s2) = do_socketpair dom typ proto in (mk_ch ~blocking:false s1, mk_ch ~blocking:false s2) external accept4 : - close_on_exec:bool -> nonblock:bool -> Unix.file_descr -> - Unix.file_descr * Unix.sockaddr = "lwt_unix_accept4" + ?cloexec:bool -> nonblock:bool -> + Unix.file_descr -> Unix.file_descr * Unix.sockaddr = "lwt_unix_accept4" -let accept_and_set_nonblock ch_fd = +let accept_and_set_nonblock ?cloexec ch_fd = if Lwt_config._HAVE_ACCEPT4 then - let (fd, addr) = accept4 ~close_on_exec:false ~nonblock:true ch_fd in + let (fd, addr) = accept4 ?cloexec ~nonblock:true ch_fd in (mk_ch ~blocking:false ~set_flags:false fd, addr) else +#if OCAML_VERSION >= (4, 05, 0) + let (fd, addr) = Unix.accept ?cloexec ch_fd in +#else let (fd, addr) = Unix.accept ch_fd in + if cloexec = Some true then Unix.set_close_on_exec fd; +#endif (mk_ch ~blocking:false fd, addr) -let accept ch = - wrap_syscall Read ch (fun _ -> accept_and_set_nonblock ch.fd) +let accept ?cloexec ch = + wrap_syscall Read ch (fun _ -> accept_and_set_nonblock ?cloexec ch.fd) -let accept_n ch n = +let accept_n ?cloexec ch n = let l = ref [] in Lazy.force ch.blocking >>= fun blocking -> Lwt.catch @@ -1720,7 +1778,7 @@ let accept_n ch n = try for _i = 1 to n do if blocking && not (unix_readable ch.fd) then raise Retry; - l := accept_and_set_nonblock ch.fd :: !l + l := accept_and_set_nonblock ?cloexec ch.fd :: !l done with | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> diff --git a/src/unix/lwt_unix.cppo.mli b/src/unix/lwt_unix.cppo.mli index 4a05d01c6c..735573df72 100644 --- a/src/unix/lwt_unix.cppo.mli +++ b/src/unix/lwt_unix.cppo.mli @@ -681,10 +681,12 @@ val access : string -> access_permission list -> unit Lwt.t (** {2 Operations on file descriptors} *) -val dup : file_descr -> file_descr +val dup : ?cloexec:bool -> + file_descr -> file_descr (** Wrapper for [Unix.dup] *) -val dup2 : file_descr -> file_descr -> unit +val dup2 : ?cloexec:bool -> + file_descr -> file_descr -> unit (** Wrapper for [Unix.dup2] *) val set_close_on_exec : file_descr -> unit @@ -751,17 +753,20 @@ val files_of_directory : string -> string Lwt_stream.t (** {2 Pipes and redirections} *) -val pipe : unit -> file_descr * file_descr +val pipe : ?cloexec:bool -> + unit -> file_descr * file_descr (** [pipe ()] creates pipe using [Unix.pipe] and returns two lwt {b file descriptor}s created from unix {b file_descriptor} *) -val pipe_in : unit -> file_descr * Unix.file_descr +val pipe_in : ?cloexec:bool -> + unit -> file_descr * Unix.file_descr (** [pipe_in ()] is the same as {!pipe} but maps only the unix {b file descriptor} for reading into a lwt one. The second is not put into non-blocking mode. You usually want to use this before forking to receive data from the child process. *) -val pipe_out : unit -> Unix.file_descr * file_descr +val pipe_out : ?cloexec:bool -> + unit -> Unix.file_descr * file_descr (** [pipe_out ()] is the inverse of {!pipe_in}. You usually want to use this before forking to send data to the child process *) @@ -874,11 +879,13 @@ type socket_type = type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int -val socket : socket_domain -> socket_type -> int -> file_descr +val socket : ?cloexec:bool -> + socket_domain -> socket_type -> int -> file_descr (** [socket domain type proto] is the same as [Unix.socket] but maps the result into a lwt {b file descriptor} *) -val socketpair : socket_domain -> socket_type -> int -> file_descr * file_descr +val socketpair : ?cloexec:bool -> + socket_domain -> socket_type -> int -> file_descr * file_descr (** Wrapper for [Unix.socketpair] *) val bind : file_descr -> sockaddr -> unit Lwt.t @@ -892,10 +899,12 @@ val bind : file_descr -> sockaddr -> unit Lwt.t val listen : file_descr -> int -> unit (** Wrapper for [Unix.listen] *) -val accept : file_descr -> (file_descr * sockaddr) Lwt.t +val accept : ?cloexec:bool -> + file_descr -> (file_descr * sockaddr) Lwt.t (** Wrapper for [Unix.accept] *) -val accept_n : file_descr -> int -> ((file_descr * sockaddr) list * exn option) Lwt.t +val accept_n : ?cloexec:bool -> + file_descr -> int -> ((file_descr * sockaddr) list * exn option) Lwt.t (** [accept_n fd count] accepts up to [count] connections at one time. - if no connection is available right now, it returns a sleeping diff --git a/src/unix/unix_c/unix_accept4.c b/src/unix/unix_c/unix_accept4.c index d582f24741..f50c114d73 100644 --- a/src/unix/unix_c/unix_accept4.c +++ b/src/unix/unix_c/unix_accept4.c @@ -20,8 +20,8 @@ CAMLprim value lwt_unix_accept4(value vcloexec, value vnonblock, value vsock) union sock_addr_union addr; socklen_param_type addr_len; - int cloexec = Int_val(vcloexec) ? SOCK_CLOEXEC : 0; - int nonblock = Int_val(vnonblock) ? SOCK_NONBLOCK : 0; + int cloexec = Is_block(vcloexec) && Bool_val(Field(vcloexec, 0)) ? SOCK_CLOEXEC : 0; + int nonblock = Bool_val(vnonblock) ? SOCK_NONBLOCK : 0; addr_len = sizeof(addr); int fd =