Skip to content

Commit

Permalink
Add ?cloexec:bool argument to wrapped Unix functions in Lwt_unix
Browse files Browse the repository at this point in the history 
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 ocsigen#327. Fix ocsigen#847. See also ocsigen#872.

[650]: ocaml/ocaml#650
  • Loading branch information
@MisterDA
MisterDA committed Nov 9, 2021
1 parent a6abacb commit 0c0a13e
Show file tree
Hide file tree
Showing 4 changed files with 106 additions and 37 deletions.
2 changes: 2 additions & 0 deletions CHANGES
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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).
Expand Down
110 changes: 84 additions & 26 deletions src/unix/lwt_unix.cppo.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand All @@ -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
Expand Down Expand Up @@ -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"
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand All @@ -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 <> [] ->
Expand Down
27 changes: 18 additions & 9 deletions src/unix/lwt_unix.cppo.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 *)

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
4 changes: 2 additions & 2 deletions src/unix/unix_c/unix_accept4.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down

0 comments on commit 0c0a13e

Please sign in to comment.