(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix (* An instance of the tester for the wait/waitpid tests. *) let () = match Sys.argv with | [|_; "--child"|] -> exit 42 | _ -> () let wait_tests = [ test "wait" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.wait () >|= function | exited_pid, Lwt_unix.WEXITED 42 when exited_pid = child_pid -> true | _ -> false end; test "waitpid" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.waitpid [] child_pid >|= function | exited_pid, Lwt_unix.WEXITED 42 when exited_pid = child_pid -> true | _ -> false end; test "waitpid: any child" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.waitpid [] 0 >|= function | exited_pid, Lwt_unix.WEXITED 42 when exited_pid = child_pid -> true | _ -> false end; test "wait4" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.wait4 [] child_pid >|= function | exited_pid, Lwt_unix.WEXITED 42, _ when exited_pid = child_pid -> true | _ -> false end; test "wait4: any child" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.wait4 [] 0 >|= function | exited_pid, Lwt_unix.WEXITED 42, _ when exited_pid = child_pid -> true | _ -> false end; ] (* The CLOEXEC tests use execv(2) to execute this code, by passing --cloexec to the copy of the tester in the child process. This is a module side effect that interprets that --cloexec argument. *) let () = let is_fd_open fd = let fd = (Obj.magic (int_of_string fd) : Unix.file_descr) in let buf = Bytes.create 1 in try ignore (Unix.read fd buf 0 1); true with Unix.Unix_error (Unix.EBADF, _, _) -> false in match Sys.argv with | [|_; "--cloexec"; fd; "--open"|] -> if is_fd_open fd then exit 0 else exit 1 | [|_; "--cloexec"; fd; "--closed"|] -> if is_fd_open fd then exit 1 else exit 0 | _ -> () let test_cloexec ~closed flags = Lwt_unix.openfile "/dev/zero" (Unix.O_RDONLY :: flags) 0o644 >>= fun fd -> match Lwt_unix.fork () with | 0 -> let fd = string_of_int (Obj.magic (Lwt_unix.unix_file_descr fd)) in let expected_status = if closed then "--closed" else "--open" in (* There's no portable way to obtain the tester executable name (which may even no longer exist at this point), but argv[0] fortunately has the right value when the tests are run in the Lwt dev environment. *) Unix.execv Sys.argv.(0) [|""; "--cloexec"; fd; expected_status|] | n -> Lwt_unix.close fd >>= fun () -> Lwt_unix.waitpid [] n >>= function | _, Unix.WEXITED 0 -> Lwt.return_true | _, (Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _) -> Lwt.return_false let openfile_tests = [ test "openfile: O_CLOEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:true [Unix.O_CLOEXEC]); test "openfile: O_CLOEXEC not given" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:false []); test "openfile: O_KEEPEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:false [Unix.O_KEEPEXEC]); test "openfile: O_CLOEXEC, O_KEEPEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:true [Unix.O_CLOEXEC; Unix.O_KEEPEXEC]); test "openfile: O_KEEPEXEC, O_CLOEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:true [Unix.O_KEEPEXEC; Unix.O_CLOEXEC]); ] let utimes_tests = [ test "utimes: basic" (fun () -> let temporary_file = Test_unix.temp_file () in Lwt_unix.utimes temporary_file 1. 2. >>= fun () -> let stat = Unix.stat temporary_file in let c1 = stat.Unix.st_atime = 1. in let c2 = stat.Unix.st_mtime = 2. in Lwt.return (instrument (c1 && c2) "utimes: basic: %f %f" stat.Unix.st_atime stat.Unix.st_mtime)); test "utimes: current time" (fun () -> (* Unix.stat reports times about an hour away from those set by Unix.utimes on Windows on MinGW. Have not searched for the root cause yet. *) let acceptable_delta = if Sys.win32 then 7200. else 2. in let now = Unix.gettimeofday () in let temporary_file = Test_unix.temp_file () in Lwt_unix.utimes temporary_file 1. 2. >>= fun () -> Lwt_unix.utimes temporary_file 0. 0. >>= fun () -> let stat = Unix.stat temporary_file in let c1 = abs_float (stat.Unix.st_atime -. now) < acceptable_delta in let c2 = abs_float (stat.Unix.st_mtime -. now) < acceptable_delta in Lwt.return (instrument (c1 && c2) "utimes: current time: %f %f %f" now stat.Unix.st_atime stat.Unix.st_mtime)); test "utimes: missing file" (fun () -> Lwt.catch (fun () -> Lwt_unix.utimes "non-existent-file" 0. 0.) (function | Unix.Unix_error (Unix.ENOENT, "utimes", _) -> Lwt.return_unit | Unix.Unix_error (Unix.EUNKNOWNERR _, "utimes", _) -> Lwt.return_unit | e -> Lwt.reraise e) >>= fun () -> Lwt.return_true); ] let readdir_tests = let populate n = let path = Test_unix.temp_directory () in let filenames = let rec loop n acc = if n <= 0 then acc else loop (n - 1) ((string_of_int n)::acc) in loop n [] in List.iter (fun filename -> let fd = Unix.(openfile (Filename.concat path filename) [O_WRONLY; O_CREAT] 0o644) in Unix.close fd) filenames; path, ["."; ".."] @ filenames in let equal, subset = let module StringSet = Set.Make (String) in (fun filenames filenames' -> StringSet.equal (StringSet.of_list filenames) (StringSet.of_list filenames')), (fun filenames filenames' -> StringSet.subset (StringSet.of_list filenames) (StringSet.of_list filenames')) in let read_all directory = let rec loop acc = Lwt.catch (fun () -> Lwt_unix.readdir directory >>= fun filename -> Lwt.return (Some filename)) (function | End_of_file -> Lwt.return_none | exn -> Lwt.reraise exn) >>= function | None -> Lwt.return acc | Some filename -> loop (filename::acc) in loop [] in let read_n directory n = let rec loop n acc = if n <= 0 then Lwt.return acc else Lwt_unix.readdir directory >>= fun filename -> loop (n - 1) (filename::acc) in loop n [] in [ test "readdir: basic" (fun () -> let path, filenames = populate 5 in Lwt_unix.opendir path >>= fun directory -> read_all directory >>= fun filenames' -> Lwt_unix.closedir directory >>= fun () -> Lwt.return (List.length filenames' = 7 && equal filenames filenames')); test "readdir: rewinddir" (fun () -> let path, filenames = populate 5 in Lwt_unix.opendir path >>= fun directory -> read_n directory 3 >>= fun filenames' -> Lwt_unix.rewinddir directory >>= fun () -> read_all directory >>= fun filenames'' -> Lwt_unix.closedir directory >>= fun () -> Lwt.return (List.length filenames' = 3 && subset filenames' filenames && List.length filenames'' = 7 && equal filenames'' filenames)); test "readdir: readdir_n" (fun () -> let path, filenames = populate 5 in Lwt_unix.opendir path >>= fun directory -> Lwt_unix.readdir_n directory 3 >>= fun filenames' -> Lwt_unix.readdir_n directory 10 >>= fun filenames'' -> Lwt_unix.closedir directory >>= fun () -> let all = (Array.to_list filenames') @ (Array.to_list filenames'') in Lwt.return (Array.length filenames' = 3 && Array.length filenames'' = 4 && equal all filenames)); test "readdir: files_of_directory" (fun () -> let path, filenames = populate 5 in let stream = Lwt_unix.files_of_directory path in Lwt_stream.to_list stream >>= fun filenames' -> Lwt.return (equal filenames' filenames)); (* Should make sure Win32 behaves in the same way as well. *) test "readdir: already closed" ~only_if:(fun () -> not Sys.win32) (fun () -> let path, _ = populate 0 in Lwt_unix.opendir path >>= fun directory -> Lwt_unix.closedir directory >>= fun () -> let expect_ebadf tag t = let tag = "Lwt_unix." ^ tag in Lwt.catch (fun () -> t () >>= fun () -> Lwt.return_false) (function | Unix.Unix_error (Unix.EBADF, tag', _) when tag' = tag -> Lwt.return_true | exn -> Lwt.reraise exn) in Lwt_list.for_all_s (fun (tag, t) -> expect_ebadf tag t) ["readdir", (fun () -> Lwt_unix.readdir directory >|= ignore); "readdir_n", (fun () -> Lwt_unix.readdir_n directory 1 >|= ignore); "rewinddir", (fun () -> Lwt_unix.rewinddir directory); "closedir", (fun () -> Lwt_unix.closedir directory)]); ] let io_vectors_byte_count_tests = let open Lwt_unix.IO_vectors in [ test "io_vector_byte_count: basic" (fun () -> let iov = create () in append_bytes iov (Bytes.create 10) 0 10; append_bigarray iov (Lwt_bytes.create 10) 0 10; Lwt.return (byte_count iov = 20)); test "io_vector_byte_count: offsets, partials" (fun () -> let iov = create () in append_bytes iov (Bytes.create 10) 5 1; append_bigarray iov (Lwt_bytes.create 10) 1 1; Lwt.return (byte_count iov = 2)); test "io_vector_byte_count: drops" (fun () -> let iov = create () in append_bytes iov (Bytes.create 10) 5 1; append_bigarray iov (Lwt_bytes.create 10) 1 1; drop iov 1; Lwt.return (byte_count iov = 1)); ] let readv_tests = (* All buffers are initially filled with '_'. *) let make_io_vectors vecs = let open Lwt_unix.IO_vectors in let io_vectors = create () in let underlying = List.map (function | `Bytes (prefix, slice_length, suffix) -> let buffer = Bytes.make (prefix + slice_length + suffix) '_' in append_bytes io_vectors buffer prefix slice_length; `Bytes buffer | `Bigarray (prefix, slice_length, suffix) -> let total_length = prefix + slice_length + suffix in let buffer = Lwt_bytes.create total_length in Lwt_bytes.fill buffer 0 total_length '_'; append_bigarray io_vectors buffer prefix slice_length; `Bigarray buffer) vecs in io_vectors, underlying in let writer write_fd data = fun () -> let data = Bytes.unsafe_of_string data in Lwt_unix.write write_fd data 0 (Bytes.length data) >>= fun bytes_written -> Lwt_unix.close write_fd >>= fun () -> (* Instrumentation for debugging an unreliable test. *) if bytes_written <> Bytes.length data then Printf.eprintf "\nwritev: expected to write %i bytes; wrote %i\n" (Bytes.length data) bytes_written; Lwt.return (bytes_written = Bytes.length data) in let reader ?(close = true) read_fd io_vectors underlying expected_count expected_data = fun () -> Gc.full_major (); let t = Lwt_unix.readv read_fd io_vectors in Gc.full_major (); t >>= fun bytes_read -> (if close then Lwt_unix.close read_fd else Lwt.return_unit) >>= fun () -> let actual = List.fold_left (fun acc -> function | `Bytes buffer -> acc ^ (Bytes.unsafe_to_string buffer) | `Bigarray buffer -> acc ^ (Lwt_bytes.to_string buffer)) "" underlying in (* Instrumentation for an unreliable test. *) if bytes_read <> expected_count then Printf.eprintf "\nreadv: expected to read %i bytes; read %i\n" expected_count bytes_read; if actual <> expected_data then Printf.eprintf "\nreadv: expected to read %s; read %s\n" expected_data actual; Lwt.return (actual = expected_data && bytes_read = expected_count) in [ test "readv: basic non-blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors, underlying = make_io_vectors [`Bytes (1, 3, 1); `Bigarray (1, 4, 1)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd "foobar"; reader read_fd io_vectors underlying 6 "_foo__bar__"]); test "readv: basic blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors, underlying = make_io_vectors [`Bytes (1, 3, 1); `Bigarray (1, 4, 1)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking read_fd true; Lwt_list.for_all_s (fun t -> t ()) [writer write_fd "foobar"; reader read_fd io_vectors underlying 6 "_foo__bar__"]); test "readv: buffer retention" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> let io_vectors, _ = make_io_vectors [ `Bigarray (3, 0, 3) ] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking read_fd true; Lwt_unix.write_string write_fd "foo" 0 3 >>= fun _ -> let retained = Lwt_unix.retained io_vectors in Lwt_unix.readv read_fd io_vectors >>= fun _ -> Lwt_unix.close write_fd >>= fun () -> Lwt_unix.close read_fd >|= fun () -> !retained end; test "readv: drop" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors, underlying = make_io_vectors [`Bytes (0, 1, 0); `Bytes (1, 4, 1)] in Lwt_unix.IO_vectors.drop io_vectors 2; let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd "foobar"; reader read_fd io_vectors underlying 3 "___foo_"]); test "readv: iovecs exceeding limit" ~only_if:(fun () -> not Sys.win32 && Lwt_unix.IO_vectors.system_limit <> None) (fun () -> let limit = match Lwt_unix.IO_vectors.system_limit with | Some limit -> limit | None -> assert false in let underlying = Array.init (limit + 1) (fun _ -> `Bytes (Bytes.make 1 '_')) |> Array.to_list in let io_vectors = Lwt_unix.IO_vectors.create () in List.iter (fun (`Bytes buffer) -> Lwt_unix.IO_vectors.append_bytes io_vectors buffer 0 1) underlying; let expected = String.make limit 'a' in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd (expected ^ "a"); reader read_fd io_vectors underlying limit (expected ^ "_")]); test "readv: windows" ~only_if:(fun () -> Sys.win32) begin fun () -> let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let io_vectors, underlying = make_io_vectors [ `Bytes (1, 3, 1); `Bigarray (1, 4, 1) ] in Lwt_list.for_all_s (fun t -> t ()) [ writer write_fd "foobar"; reader ~close:false read_fd io_vectors underlying 3 "_foo_______"; (fun () -> Lwt_unix.IO_vectors.drop io_vectors 3; Lwt.return_true); reader read_fd io_vectors underlying 3 "_foo__bar__"; ] end; ] let writev_tests = let make_io_vectors vecs = let open Lwt_unix.IO_vectors in let io_vectors = create () in List.iter (function | `Bytes (s, offset, length) -> append_bytes io_vectors (Bytes.unsafe_of_string s) offset length | `Bigarray (s, offset, length) -> append_bigarray io_vectors (Lwt_bytes.of_string s) offset length) vecs; io_vectors in let writer ?(close = true) ?blocking write_fd io_vectors data_length = fun () -> Lwt_unix.blocking write_fd >>= fun is_blocking -> Gc.full_major (); let t = Lwt_unix.writev write_fd io_vectors in Gc.full_major (); t >>= fun bytes_written -> (if close then Lwt_unix.close write_fd else Lwt.return_unit) >>= fun () -> let blocking_matches = match blocking, is_blocking with | Some v, v' when v <> v' -> Printf.eprintf "\nblocking: v = %b, v' = %b\n" v v'; false | _ -> true in if bytes_written <> data_length then Printf.eprintf "\nwritev: expected to write %i bytes; wrote %i\n" data_length bytes_written; Lwt.return (bytes_written = data_length && blocking_matches) in let reader read_fd ?(not_readable = false) expected_data = fun () -> if not_readable then let readable = Lwt_unix.readable read_fd in Lwt_unix.close read_fd >>= fun () -> if readable then Printf.eprintf "\nreadable: %b\n" readable; Lwt.return (not readable) else let open! Lwt_io in let channel = of_fd ~mode:input read_fd in read channel >>= fun read_data -> close channel >>= fun () -> if read_data <> expected_data then Printf.eprintf "\nreadv: expected to read %s; read %s (length %i)\n" expected_data read_data (String.length read_data); Lwt.return (read_data = expected_data) in [ test "writev: basic non-blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3); `Bytes ("bar", 0, 3); `Bigarray ("baz", 0, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer ~blocking:false write_fd io_vectors 9; reader read_fd "foobarbaz"]); test "writev: basic blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3); `Bytes ("bar", 0, 3); `Bigarray ("baz", 0, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking write_fd true; Lwt_list.for_all_s (fun t -> t ()) [writer ~blocking:true write_fd io_vectors 9; reader read_fd "foobarbaz"]); test "writev: buffer retention" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> let io_vectors = make_io_vectors [ `Bigarray ("foo", 0, 3) ] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking write_fd true; let retained = Lwt_unix.retained io_vectors in Lwt_unix.writev write_fd io_vectors >>= fun _ -> Lwt_unix.close write_fd >>= fun () -> Lwt_unix.close read_fd >|= fun () -> !retained end; test "writev: slices" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 1, 2); `Bigarray ("bar", 1, 2)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 4; reader read_fd "ooar"]); test "writev: drop, is_empty" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3); `Bytes ("bar", 0, 3); `Bigarray ("baz", 0, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let initially_empty = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_unix.IO_vectors.drop io_vectors 4; let empty_after_partial_drop = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 5; reader read_fd "arbaz"] >>= fun io_correct -> Lwt_unix.IO_vectors.drop io_vectors 5; let empty_after_exact_drop = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_unix.IO_vectors.drop io_vectors 100; let empty_after_excess_drop = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt.return (not initially_empty && not empty_after_partial_drop && io_correct && empty_after_exact_drop && empty_after_excess_drop)); test "writev: degenerate vectors" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 0); `Bigarray ("bar", 0, 0)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let initially_empty = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 0; reader read_fd ""] >>= fun io_correct -> Lwt.return (initially_empty && io_correct)); test "writev: bad iovec" ~only_if:(fun () -> not Sys.win32) (fun () -> let negative_offset = make_io_vectors [`Bytes ("foo", -1, 3)] in let negative_length = make_io_vectors [`Bytes ("foo", 0, -1)] in let out_of_bounds = make_io_vectors [`Bytes ("foo", 1, 3)] in let negative_offset' = make_io_vectors [`Bigarray ("foo", -1, 3)] in let negative_length' = make_io_vectors [`Bigarray ("foo", 0, -1)] in let out_of_bounds' = make_io_vectors [`Bigarray ("foo", 1, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let writer io_vectors = fun () -> Lwt.catch (fun () -> Lwt_unix.writev write_fd io_vectors >>= fun _ -> Lwt.return_false) (function | Invalid_argument _ -> Lwt.return_true | e -> Lwt.reraise e) in let close write_fd = fun () -> Lwt_unix.close write_fd >>= fun () -> Lwt.return_true in Lwt_list.for_all_s (fun t -> t ()) [writer negative_offset; writer negative_length; writer out_of_bounds; writer negative_offset'; writer negative_length'; writer out_of_bounds'; reader read_fd ~not_readable:true ""; close write_fd]); test "writev: iovecs exceeding limit" ~only_if:(fun () -> not Sys.win32 && Lwt_unix.IO_vectors.system_limit <> None) (fun () -> let limit = match Lwt_unix.IO_vectors.system_limit with | Some limit -> limit | None -> assert false in let io_vectors = let open Lwt_unix.IO_vectors in let io_vectors = create () in let rec loop count = if count < 1 then io_vectors else (append_bytes io_vectors (Bytes.unsafe_of_string "a") 0 1; loop (count - 1)) in loop (limit + 1) in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors limit; reader read_fd (String.make limit 'a')]); test "writev: negative drop" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3)] in Lwt_unix.IO_vectors.drop io_vectors (-1); let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 3; reader read_fd "foo"] >>= fun io_correct -> Lwt.return (io_correct && not (Lwt_unix.IO_vectors.is_empty io_vectors))); test "writev: windows" ~only_if:(fun () -> Sys.win32) begin fun () -> let io_vectors = make_io_vectors [ `Bytes ("foo", 0, 3); `Bigarray ("bar", 0, 3); ] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [ writer ~close:false write_fd io_vectors 3; (fun () -> Lwt_unix.IO_vectors.drop io_vectors 3; Lwt.return_true); writer write_fd io_vectors 3; reader read_fd "foobar"; ] end; ] let send_recv_msg_tests = [ test "send_msg, recv_msg" ~only_if:(fun () -> not Sys.win32) begin fun () -> let socket_1, socket_2 = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) in let pipe_read, pipe_write = Lwt_unix.pipe ~cloexec:true () in let source_buffer = Bytes.of_string "_foo_bar_" in let source_iovecs = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bytes source_iovecs source_buffer 1 3; Lwt_unix.IO_vectors.append_bytes source_iovecs source_buffer 5 3; Lwt_unix.send_msg ~socket:socket_1 ~io_vectors:source_iovecs ~fds:[Lwt_unix.unix_file_descr pipe_write] >>= fun n -> if n <> 6 then Lwt.return_false else let destination_buffer = Bytes.of_string "_________" in let destination_iovecs = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bytes destination_iovecs destination_buffer 5 3; Lwt_unix.IO_vectors.append_bytes destination_iovecs destination_buffer 1 3; Lwt_unix.recv_msg ~socket:socket_2 ~io_vectors:destination_iovecs >>= fun (n, fds) -> let succeeded = match n, fds, Bytes.to_string destination_buffer with | 6, [fd], "_bar_foo_" -> Some fd | _ -> None in match succeeded with | None -> Lwt.return_false | Some fd -> let n = Unix.write fd (Bytes.of_string "baz") 0 3 in if n <> 3 then Lwt.return_false else let buffer = Bytes.create 3 in Lwt_unix.read pipe_read buffer 0 3 >>= fun n -> match n, Bytes.to_string buffer with | 3, "baz" -> Lwt_unix.close socket_1 >>= fun () -> Lwt_unix.close socket_2 >>= fun () -> Lwt_unix.close pipe_read >>= fun () -> Lwt_unix.close pipe_write >>= fun () -> Unix.close fd; Lwt.return_true | _ -> Lwt.return_false end; test "send_msg, recv_msg (Lwt_bytes, old)" ~only_if:(fun () -> not Sys.win32) begin fun () -> let socket_1, socket_2 = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) in let pipe_read, pipe_write = Lwt_unix.pipe ~cloexec:true () in let source_buffer = Lwt_bytes.of_string "_foo_bar_" in let source_iovecs = Lwt_bytes.[ { iov_buffer = source_buffer; iov_offset = 1; iov_length = 3; }; { iov_buffer = source_buffer; iov_offset = 5; iov_length = 3; }; ] in (Lwt_bytes.send_msg [@ocaml.warning "-3"]) ~socket:socket_1 ~io_vectors:source_iovecs ~fds:[Lwt_unix.unix_file_descr pipe_write] >>= fun n -> if n <> 6 then Lwt.return_false else let destination_buffer = Lwt_bytes.of_string "_________" in let destination_iovecs = Lwt_bytes.[ { iov_buffer = destination_buffer; iov_offset = 5; iov_length = 3; }; { iov_buffer = destination_buffer; iov_offset = 1; iov_length = 3; }; ] in (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket:socket_2 ~io_vectors:destination_iovecs >>= fun (n, fds) -> let succeeded = match n, fds, Lwt_bytes.to_string destination_buffer with | 6, [fd], "_bar_foo_" -> Some fd | _ -> None in match succeeded with | None -> Lwt.return_false | Some fd -> let n = Unix.write fd (Bytes.of_string "baz") 0 3 in if n <> 3 then Lwt.return_false else let buffer = Bytes.create 3 in Lwt_unix.read pipe_read buffer 0 3 >>= fun n -> match n, Bytes.to_string buffer with | 3, "baz" -> Lwt_unix.close socket_1 >>= fun () -> Lwt_unix.close socket_2 >>= fun () -> Lwt_unix.close pipe_read >>= fun () -> Lwt_unix.close pipe_write >>= fun () -> Unix.close fd; Lwt.return_true | _ -> Lwt.return_false end; ] let bind_tests_address = Unix.(ADDR_INET (inet_addr_loopback, 56100)) let bind_tests = let directory_exists dir = try Sys.is_directory dir with Sys_error _ -> false in [ test "bind: basic" (fun () -> let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt.finalize (fun () -> Lwt_unix.bind socket bind_tests_address >>= fun () -> Lwt.return (Unix.getsockname (Lwt_unix.unix_file_descr socket))) (fun () -> Lwt_unix.close socket) >>= fun address' -> Lwt.return (address' = bind_tests_address)); test "bind: Unix domain" ~only_if:(fun () -> not Sys.win32 && not (directory_exists "/hurd")) (fun () -> let socket = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in let rec bind_loop attempts = let path = Test_unix.temp_name () in let address = Unix.(ADDR_UNIX path) in Lwt.catch (fun () -> Lwt_unix.bind socket address >>= fun () -> Lwt.return path) (function | Unix.Unix_error (Unix.EADDRINUSE, "bind", _) | Unix.Unix_error (Unix.EISDIR, "bind", _) as exn -> if attempts <= 1 then Lwt.reraise exn else bind_loop (attempts - 1) | Unix.Unix_error (Unix.EPERM, "bind", _) -> (* On EPERM, assume that we are under WSL, but in the Windows filesystem. If this ever results in a false positive, this test should add a check for WSL by checking for the existence of /proc/version, reading it, and checking its contents for the string "WSL". *) raise Skip | e -> Lwt.reraise e) in Lwt.finalize (fun () -> bind_loop 5 >>= fun chosen_path -> let actual_path = Unix.getsockname (Lwt_unix.unix_file_descr socket) in Lwt.return (chosen_path, actual_path)) (fun () -> Lwt_unix.close socket) >>= fun (chosen_path, actual_path) -> let actual_path = match actual_path with | Unix.ADDR_UNIX path -> path | Unix.ADDR_INET _ -> assert false in (try Unix.unlink chosen_path with _ -> ()); (try Unix.unlink actual_path with _ -> ()); (* Compare with a prefix of the actual path, due to https://github.com/ocaml/ocaml/pull/987 *) try Lwt.return (chosen_path = String.sub actual_path 0 (String.length chosen_path)) with Invalid_argument _ -> Lwt.return_false); test "bind: closed" (fun () -> let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt_unix.close socket >>= fun () -> Lwt.catch (fun () -> Lwt_unix.bind socket bind_tests_address >>= fun () -> Lwt.return_false) (function | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_true | e -> Lwt.reraise e)); test "bind: aborted" (fun () -> let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt_unix.abort socket Exit; Lwt.finalize (fun () -> Lwt.catch (fun () -> Lwt_unix.bind socket bind_tests_address >>= fun () -> Lwt.return_false) (function | Exit -> Lwt.return_true | e -> Lwt.reraise e)) (fun () -> Lwt_unix.close socket)); ] let dir_tests = [ test "getcwd" (fun () -> Lwt_unix.getcwd () >>= fun (_:string) -> Lwt.return_true ); test "getcwd and chdir" (fun () -> Lwt_unix.getcwd () >>= fun here -> Lwt_unix.chdir here >>= fun () -> Lwt_unix.getcwd () >>= fun there -> Lwt.return (here = there) ); test "getcwd and Unix.getcwd" (fun () -> let unix_here = Unix.getcwd () in Lwt_unix.getcwd () >>= fun here -> Lwt.return (here = unix_here) ); ] let lwt_preemptive_tests = [ test "run_in_main" begin fun () -> let f () = Lwt_preemptive.run_in_main (fun () -> Lwt_unix.sleep 0.01 >>= fun () -> Lwt.return 42) in Lwt_preemptive.detach f () >>= fun x -> Lwt.return (x = 42) end; test "run_in_main_dont_wait" begin fun () -> let p, r = Lwt.wait () in let f () = Lwt_preemptive.run_in_main_dont_wait (fun () -> Lwt.pause () >>= fun () -> Lwt.pause () >>= fun () -> Lwt.wakeup r 42; Lwt.return ()) (fun _ -> assert false) in Lwt_preemptive.detach f () >>= fun () -> p >>= fun x -> Lwt.return (x = 42) end; test "run_in_main_dont_wait_fail" begin fun () -> let p, r = Lwt.wait () in let f () = Lwt_preemptive.run_in_main_dont_wait (fun () -> Lwt.pause () >>= fun () -> Lwt.pause () >>= fun () -> raise Exit) (function Exit -> Lwt.wakeup r 45 | _ -> assert false) in Lwt_preemptive.detach f () >>= fun () -> p >>= fun x -> Lwt.return (x = 45) end; test "run_in_main_with_dont_wait" begin fun () -> let p, r = Lwt.wait () in let f () = Lwt_preemptive.run_in_main (fun () -> Lwt.dont_wait (fun () -> Lwt.pause () >>= fun () -> Lwt.pause () >>= fun () -> Lwt.wakeup r 42; Lwt.return ()) (function _ -> Stdlib.exit 2); Lwt.return ()) in Lwt_preemptive.detach f () >>= fun () -> p >>= fun x -> Lwt.return (x = 42) end; ] let getlogin_works = if Sys.win32 then false else match Unix.getlogin () with | _ -> true | exception Unix.Unix_error _ -> false let lwt_user_tests = [ test "getlogin and Unix.getlogin" ~only_if:(fun () -> getlogin_works) begin fun () -> let unix_user = Unix.getlogin () in Lwt_unix.getlogin () >>= fun user -> Lwt.return (user = unix_user) end; test "getpwnam and Unix.getpwnam" ~only_if:(fun () -> getlogin_works) begin fun () -> let unix_user = Unix.getlogin () in let unix_password = Unix.getpwnam unix_user in Lwt_unix.getpwnam unix_user >>= fun password -> Lwt.return (password = unix_password) end; test "getpwuid and Unix.getpwuid" ~only_if:(fun () -> getlogin_works) begin fun () -> let pwnam = Unix.getpwnam (Unix.getlogin ()) in let unix_pwuid = Unix.getpwuid pwnam.pw_uid in Lwt_unix.getpwuid pwnam.pw_uid >>= fun pwuid -> Lwt.return (pwuid = unix_pwuid) end; test "getgrgid and Unix.getgrgid" ~only_if:(fun () -> not Sys.win32) begin fun () -> let group_id = Unix.getgid () in let unix_group = Unix.getgrgid group_id in Lwt_unix.getgrgid group_id >>= fun group -> Lwt.return (group = unix_group) end; test "getgrnam and Unix.getgrnam" ~only_if:(fun () -> not Sys.win32) begin fun () -> let group_id = Unix.getgid () in let unix_group = Unix.getgrgid group_id in let group_name = unix_group.gr_name in Lwt_unix.getgrnam group_name >>= fun group -> Lwt.return (group = unix_group) end ] let file_suffix = let last_file_suffix = ref 0 in fun () -> incr last_file_suffix; !last_file_suffix let test_filename name = Printf.sprintf "%s_%i" name (file_suffix ()) let pread_tests ~blocking = let test_file = test_filename "test_pread_pwrite" in let file_contents = "01234567890123456789" in let blocking_string = if blocking then " blocking" else " nonblocking" in [ test ~sequential:true ("basic pread" ^ blocking_string) (fun () -> Lwt_unix.openfile test_file [O_RDWR; O_TRUNC; O_CREAT] 0o666 >>= fun fd -> if not blocking then Lwt_unix.set_blocking ~set_flags:false fd false; Lwt_unix.write_string fd file_contents 0 (String.length file_contents) >>= fun n -> assert(n = String.length file_contents); (* This should always be true in practice, show it if this is the reason for failing *) let buf = Bytes.make 3 '\x00' in Lwt_unix.pread fd buf ~file_offset:3 0 3 >>= fun n -> assert(n = 3); let read1 = Bytes.to_string buf in Lwt_unix.pread fd buf ~file_offset:15 0 3 >>= fun n -> assert(n = 3); let read2 = Bytes.to_string buf in Lwt_unix.close fd >>= fun () -> Lwt.return (read1 = "345" && read2 = "567")); test ~sequential:true ("basic pwrite" ^ blocking_string) (fun () -> Lwt_unix.openfile test_file [O_RDWR] 0o666 >>= fun fd -> if not blocking then Lwt_unix.set_blocking ~set_flags:false fd false; let t1 = Lwt_unix.pwrite_string fd "abcd" ~file_offset:5 0 4 in let t2 = Lwt_unix.pwrite_string fd "efg" ~file_offset:15 0 3 in t2 >>= fun l2 -> t1 >>= fun l1 -> assert(l1 = 4); assert(l2 = 3); Lwt_unix.lseek fd 0 Lwt_unix.SEEK_SET >>= fun _pos -> let buf = Bytes.make (String.length file_contents) '\x00' in Lwt_unix.read fd buf 0 (String.length file_contents) >>= fun n -> assert(n = (String.length file_contents)); Lwt_unix.close fd >>= fun () -> let read = Bytes.to_string buf in Lwt.return (read = "01234abcd901234efg89")); test ~sequential:true ("remove file" ^ blocking_string) (fun () -> Unix.unlink test_file; Lwt.return_true); ] let dup_tests ~blocking = let test_file = test_filename "test_dup" in let file_contents = "01234567890123456789" in let len = String.length file_contents in let buf = Bytes.make len '\x00' in let blocking_string = if blocking then " blocking" else " nonblocking" in [ test ~sequential:true ("dup on socket" ^ blocking_string) (fun () -> let s1, s2 = if Sys.win32 then Lwt_unix.socketpair Unix.PF_INET6 Unix.SOCK_STREAM 0 else Lwt_unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in if not blocking then Lwt_unix.set_blocking ~set_flags:false s1 false; let s1' = Lwt_unix.dup s1 in Lwt_unix.blocking s1 >>= fun s1_is_blocking -> Lwt_unix.blocking s1' >>= fun s1'_is_blocking -> assert(s1_is_blocking = s1'_is_blocking); Lwt_unix.write_string s1 file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.read s2 buf 0 len >>= fun n -> assert(n = len); let read = Bytes.to_string buf in assert(read = file_contents); Lwt_unix.write_string s1' file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.read s2 buf 0 len >>= fun n -> assert(n = len); let read = Bytes.to_string buf in assert(read = file_contents); Lwt_list.iter_p Lwt_unix.close [s1; s1'; s2] >>= fun () -> Lwt.return_true); test ~sequential:true ("dup on file" ^ blocking_string) (fun () -> Lwt_unix.openfile test_file [O_RDWR; O_TRUNC; O_CREAT] 0o666 >>= fun fd -> if not blocking then Lwt_unix.set_blocking ~set_flags:false fd false; let fd' = Lwt_unix.dup fd in Lwt_unix.blocking fd >>= fun fd_is_blocking -> Lwt_unix.blocking fd' >>= fun fd'_is_blocking -> assert(fd_is_blocking = fd'_is_blocking); Lwt_unix.write_string fd file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.lseek fd 0 Lwt_unix.SEEK_SET >>= fun _pos -> let buf = Bytes.make (String.length file_contents) '\x00' in Lwt_unix.read fd buf 0 (String.length file_contents) >>= fun n -> assert(n = (String.length file_contents)); let read = Bytes.to_string buf in assert (read = file_contents); Lwt_unix.write_string fd' file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.lseek fd' 0 Lwt_unix.SEEK_SET >>= fun _pos -> let buf = Bytes.make (String.length file_contents) '\x00' in Lwt_unix.read fd' buf 0 (String.length file_contents) >>= fun n -> assert(n = (String.length file_contents)); let read = Bytes.to_string buf in assert (read = file_contents); Lwt.return_true); ] let suite = suite "lwt_unix" (wait_tests @ openfile_tests @ utimes_tests @ readdir_tests @ io_vectors_byte_count_tests @ readv_tests @ writev_tests @ send_recv_msg_tests @ bind_tests @ dir_tests @ lwt_preemptive_tests @ lwt_user_tests @ pread_tests ~blocking:true @ pread_tests ~blocking:false @ dup_tests ~blocking:true @ dup_tests ~blocking:false )