(* 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. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) module Lwt_sequence = Lwt_sequence open Test open Lwt.Infix exception Dummy_error let local = let last_port = ref 4321 in fun () -> incr last_port; Unix.ADDR_INET (Unix.inet_addr_loopback, !last_port) (* Helpers for [establish_server] tests. *) module Establish_server = struct let with_client f = let local = local () in let handler_finished, notify_handler_finished = Lwt.wait () in Lwt_io.establish_server_with_client_address local (fun _client_address channels -> Lwt.finalize (fun () -> f channels) (fun () -> Lwt.wakeup notify_handler_finished (); Lwt.return_unit)) >>= fun server -> let client_finished = Lwt_io.with_connection local (fun (_, out_channel) -> Lwt_io.write out_channel "hello world" >>= fun () -> handler_finished) in client_finished >>= fun () -> Lwt_io.shutdown_server server (* Hacky is_closed functions that attempt to read from/write to the channels to see if they are closed. *) let is_closed_in channel = Lwt.catch (fun () -> Lwt_io.read_char channel >|= fun _ -> false) (function | Lwt_io.Channel_closed _ -> Lwt.return_true | _ -> Lwt.return_false) let is_closed_out channel = Lwt.catch (fun () -> Lwt_io.write_char channel 'a' >|= fun () -> false) (function | Lwt_io.Channel_closed _ -> Lwt.return_true | _ -> Lwt.return_false) end let suite = suite "lwt_io" [ test "auto-flush" ~sequential:true (fun () -> let sent = ref [] in let oc = Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; Lwt.return len) in Lwt_io.write oc "foo" >>= fun () -> Lwt_io.write oc "bar" >>= fun () -> if !sent <> [] then begin prerr_endline "auto-flush: !sent not empty"; Lwt.return_false end else Lwt_unix.sleep 0.1 >>= fun () -> let test_result = !sent = [Bytes.of_string "foobar"] in if not test_result then !sent |> List.map Bytes.to_string |> List.map (Printf.sprintf "'%s'") |> String.concat "," |> Printf.eprintf "auto-flush: !sent = %s"; Lwt.return test_result); test "auto-flush in atomic" ~sequential:true (fun () -> let sent = ref [] in let oc = Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; Lwt.return len) in Lwt_io.atomic (fun oc -> Lwt_io.write oc "foo" >>= fun () -> Lwt_io.write oc "bar" >>= fun () -> if !sent <> [] then begin prerr_endline "auto-flush atomic: !sent not empty"; Lwt.return_false end else Lwt_unix.sleep 0.1 >>= fun () -> let test_result = !sent = [Bytes.of_string "foobar"] in if not test_result then !sent |> List.map Bytes.to_string |> List.map (Printf.sprintf "'%s'") |> String.concat "," |> Printf.eprintf "auto-flush atomic: !sent = %s"; Lwt.return test_result) oc); (* Without the corresponding bugfix, which is to handle ENOTCONN from Lwt_unix.shutdown, this test raises an exception from the handler's calls to close. *) test "establish_server_1: shutdown: client closes first" ~only_if:(fun () -> not (Lwt_config._HAVE_LIBEV && Lwt_config.libev_default)) (* Note: this test is currently flaky on Linux with libev enabled, so we skip it in that case. *) (fun () -> let wait_for_client, client_finished = Lwt.wait () in let handler_wait, run_handler = Lwt.wait () in let handler = handler_wait >>= fun (in_channel, out_channel) -> wait_for_client >>= fun () -> Lwt_io.close in_channel >>= fun () -> Lwt_io.close out_channel >>= fun () -> Lwt.return_true in let local = local () in let server = (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) local (fun channels -> Lwt.wakeup run_handler channels) in Lwt_io.with_connection local (fun _ -> Lwt.return_unit) >>= fun () -> Lwt.wakeup client_finished (); Lwt_io.shutdown_server server >>= fun () -> handler); (* Counterpart to establish_server: shutdown test. Confirms that shutdown is implemented correctly in open_connection. *) test "open_connection: shutdown: server closes first" (fun () -> let wait_for_server, server_finished = Lwt.wait () in let local = local () in let server = (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) local (fun (in_channel, out_channel) -> Lwt.async (fun () -> Lwt_io.close in_channel >>= fun () -> Lwt_io.close out_channel >|= fun () -> Lwt.wakeup server_finished ())) in Lwt_io.with_connection local (fun _ -> wait_for_server >>= fun () -> Lwt.return_true) >>= fun result -> Lwt_io.shutdown_server server >|= fun () -> result); test "establish_server: implicit close" (fun () -> let open Establish_server in let in_channel' = ref Lwt_io.stdin in let out_channel' = ref Lwt_io.stdout in let in_open_in_handler = ref false in let out_open_in_handler = ref false in let run = Establish_server.with_client (fun (in_channel, out_channel) -> in_channel' := in_channel; out_channel' := out_channel; is_closed_out out_channel >>= fun yes -> out_open_in_handler := not yes; is_closed_in in_channel >|= fun yes -> in_open_in_handler := not yes) in run >>= fun () -> (* Give a little time for the close system calls on the connection sockets to complete. The Lwt_io and Lwt_unix APIs do not currently allow binding on the implicit closes of these sockets, so resorting to a delay. *) Lwt_unix.sleep 0.05 >>= fun () -> is_closed_in !in_channel' >>= fun in_closed_after_handler -> is_closed_out !out_channel' >|= fun out_closed_after_handler -> !out_open_in_handler && !in_open_in_handler && in_closed_after_handler && out_closed_after_handler); test ~sequential:true "establish_server: implicit close on exception" (fun () -> let open Establish_server in let in_channel' = ref Lwt_io.stdin in let out_channel' = ref Lwt_io.stdout in let exit_raised = ref false in let run () = Establish_server.with_client (fun (in_channel, out_channel) -> in_channel' := in_channel; out_channel' := out_channel; raise Exit) in with_async_exception_hook (function | Exit -> exit_raised := true; | _ -> ()) run >>= fun () -> (* See comment in other implicit close test. *) Lwt_unix.sleep 0.05 >>= fun () -> is_closed_in !in_channel' >>= fun in_closed_after_handler -> is_closed_out !out_channel' >|= fun out_closed_after_handler -> in_closed_after_handler && out_closed_after_handler); (* This does a simple double close of the channels (second close is implicit). If something breaks, the test will finish with an exception, or Lwt.async_exception_hook will kill the process. *) test "establish_server: explicit close" (fun () -> let open Establish_server in let closed_explicitly = ref false in let run = Establish_server.with_client (fun (in_channel, out_channel) -> Lwt_io.close in_channel >>= fun () -> Lwt_io.close out_channel >>= fun () -> is_closed_in in_channel >>= fun in_closed_in_handler -> is_closed_out out_channel >|= fun out_closed_in_handler -> closed_explicitly := in_closed_in_handler && out_closed_in_handler) in run >|= fun () -> !closed_explicitly); test "with_connection" (fun () -> let open Establish_server in let in_channel' = ref Lwt_io.stdin in let out_channel' = ref Lwt_io.stdout in let local = local () in Lwt_io.establish_server_with_client_address local (fun _client_address _channels -> Lwt.return_unit) >>= fun server -> Lwt_io.with_connection local (fun (in_channel, out_channel) -> in_channel' := in_channel; out_channel' := out_channel; Lwt.return_unit) >>= fun () -> Lwt_io.shutdown_server server >>= fun () -> is_closed_in !in_channel' >>= fun in_closed -> is_closed_out !out_channel' >|= fun out_closed -> in_closed && out_closed); (* Makes the channel fail with EBADF on close. Tries to close the channel manually, and handles the exception. When with_close_connection tries to close the socket again implicitly, that should not raise the exception again. *) test "with_close_connection: no duplicate exceptions" (fun () -> let exceptions_observed = ref 0 in let expecting_ebadf f = Lwt.catch f (function | Unix.Unix_error (Unix.EBADF, _, _) -> exceptions_observed := !exceptions_observed + 1; Lwt.return_unit | exn -> Lwt.reraise exn) in let fd_r, fd_w = Lwt_unix.pipe () in let in_channel = Lwt_io.of_fd ~mode:Lwt_io.input fd_r in let out_channel = Lwt_io.of_fd ~mode:Lwt_io.output fd_w in Lwt_unix.close fd_r >>= fun () -> Lwt_unix.close fd_w >>= fun () -> expecting_ebadf (fun () -> Lwt_io.with_close_connection (fun _ -> expecting_ebadf (fun () -> Lwt_io.close in_channel) >>= fun () -> expecting_ebadf (fun () -> Lwt_io.close out_channel)) (in_channel, out_channel)) >|= fun () -> !exceptions_observed = 2); test "open_temp_file" (fun () -> Lwt_io.open_temp_file () >>= fun (fname, out_chan) -> Lwt_io.write out_chan "test file content" >>= fun () -> Lwt_io.close out_chan >>= fun _ -> Unix.unlink fname; Lwt.return_true ); test "with_temp_filename" (fun () -> let prefix = "test_tempfile" in let filename = ref "." in let wrap f (filename', chan) = filename := filename'; f chan in let write_data chan = Lwt_io.write chan "test file content" in let write_data_fail _ = Lwt.fail Dummy_error in Lwt_io.with_temp_file (wrap write_data) ~prefix >>= fun _ -> let no_temps1 = not (Sys.file_exists !filename) in Lwt.catch (fun () -> Lwt_io.with_temp_file (wrap write_data_fail)) (fun exn -> if exn = Dummy_error then Lwt.return (not (Sys.file_exists !filename)) else Lwt.return_false ) >>= fun no_temps2 -> Lwt.return (no_temps1 && no_temps2) ); (* Verify that no exceptions are thrown if the function passed to with_temp_file closes the channel on its own. *) test "with_temp_filename close handle" (fun () -> let f (_, chan) = Lwt_io.write chan "test file content" >>= fun _ -> Lwt_io.close chan in Lwt_io.with_temp_file f >>= fun _ -> Lwt.return_true; ); test "create_temp_dir" begin fun () -> let prefix = "temp_dir" in let suffix = "_foo" in Lwt_io.create_temp_dir ~parent:Filename.current_dir_name ~prefix ~suffix () >>= fun path -> let name = Filename.basename path in let prefix_matches = String.sub name 0 (String.length prefix) = prefix in let actual_suffix = String.sub name (String.length name - String.length suffix) (String.length suffix) in let suffix_matches = actual_suffix = suffix in let directory_exists = Sys.is_directory path in Lwt_unix.rmdir path >>= fun () -> Lwt.return (prefix_matches && suffix_matches && directory_exists) end; test "with_temp_dir" ~sequential:true begin fun () -> Lwt_io.with_temp_dir ~parent:Filename.current_dir_name ~prefix:"temp_dir" begin fun path -> let directory_existed = Sys.is_directory path in open_out (Filename.concat path "foo") |> close_out; open_out (Filename.concat path "bar") |> close_out; let had_files = Array.length (Sys.readdir path) = 2 in Lwt.return (path, directory_existed, had_files) end >>= fun (path, directory_existed, had_files) -> let directory_removed = not (Sys.file_exists path) in Lwt.return (directory_existed && had_files && directory_removed) end; test "file_length on directory" begin fun () -> Lwt.catch (fun () -> Lwt_io.file_length "." >>= fun _ -> Lwt.return_false) (function | Unix.Unix_error (Unix.EISDIR, "file_length", ".") -> Lwt.return_true | exn -> Lwt.reraise exn) end; test "input channel of_bytes initial position" (fun () -> let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in Lwt.return (Lwt_io.position ichan = 0L) ); test "input channel of_bytes position after read" (fun () -> let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in Lwt_io.read_char ichan >|= fun _ -> Lwt_io.position ichan = 1L ); test "input channel of_bytes position after set_position" (fun () -> let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in Lwt_io.set_position ichan 2L >|= fun () -> Lwt_io.position ichan = 2L ); test "output channel of_bytes initial position" (fun () -> let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in Lwt.return (Lwt_io.position ochan = 0L) ); test "output channel of_bytes position after read" (fun () -> let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in Lwt_io.write_char ochan 'a' >|= fun _ -> Lwt_io.position ochan = 1L ); test "output channel of_bytes position after set_position" (fun () -> let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in Lwt_io.set_position ochan 2L >|= fun _ -> Lwt_io.position ochan = 2L ); test "NumberIO.LE.read_int" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int >|= (=) 0x04030201 end; test "NumberIO.BE.read_int" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int >|= (=) 0x01020304 end; test "NumberIO.LE.read_int16" begin fun () -> Lwt_bytes.of_string "\x01\x02" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int16 >|= (=) 0x0201 end; test "NumberIO.BE.read_int16" begin fun () -> Lwt_bytes.of_string "\x01\x02" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int16 >|= (=) 0x0102 end; test "NumberIO.LE.read_int16, negative" begin fun () -> Lwt_bytes.of_string "\xfe\xff" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int16 >|= (=) (-2) end; test "NumberIO.BE.read_int16, negative" begin fun () -> Lwt_bytes.of_string "\xff\xfe" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int16 >|= (=) (-2) end; test "NumberIO.LE.read_int32" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int32 >|= (=) 0x04030201l end; test "NumberIO.BE.read_int32" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int32 >|= (=) 0x01020304l end; test "NumberIO.LE.read_int64" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int64 >|= (=) 0x0807060504030201L end; test "NumberIO.BE.read_int64" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int64 >|= (=) 0x0102030405060708L end; test "NumberIO.LE.read_float32" begin fun () -> Lwt_bytes.of_string "\x80\x01\x81\x47" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_float32 >|= fun n -> instrument (n = 66051.) "NumberIO.LE.read_float32: %f" n end; test "NumberIO.BE.read_float32" begin fun () -> Lwt_bytes.of_string "\x47\x81\x01\x80" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_float32 >|= fun n -> instrument (n = 66051.) "NumberIO.BE.read_float32: %f" n end; test "NumberIO.LE.read_float64" begin fun () -> Lwt_bytes.of_string "\x70\x60\x50\x40\x30\x20\xf0\x42" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_float64 >|= Int64.bits_of_float >|= (=) 0x42F0203040506070L end; test "NumberIO.BE.read_float64" begin fun () -> Lwt_bytes.of_string "\x42\xf0\x20\x30\x40\x50\x60\x70" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_float64 >|= Int64.bits_of_float >|= (=) 0x42F0203040506070L end; test "NumberIO.LE.write_int" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.LE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01") end; test "NumberIO.BE.write_int" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.BE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04") end; test "NumberIO.LE.write_int16" begin fun () -> let buffer = Lwt_bytes.create 2 in Lwt_io.LE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x02\x01") end; test "NumberIO.BE.write_int16" begin fun () -> let buffer = Lwt_bytes.create 2 in Lwt_io.BE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02") end; test "NumberIO.LE.write_int32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.LE.write_int32 (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304l >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01") end; test "NumberIO.BE.write_int32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.BE.write_int32 (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304l >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04") end; test "NumberIO.LE.write_int64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.LE.write_int64 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102030405060708L >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x08\x07\x06\x05\x04\x03\x02\x01") end; test "NumberIO.BE.write_int64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.BE.write_int64 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102030405060708L >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04\x05\x06\x07\x08") end; test "NumberIO.LE.write_float32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.LE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) 66051. >|= fun () -> instrument (Lwt_bytes.to_string buffer = "\x80\x01\x81\x47") "NumberIO.LE.write_float32: %02X %02X %02X %02X" (Char.code (Lwt_bytes.get buffer 0)) (Char.code (Lwt_bytes.get buffer 1)) (Char.code (Lwt_bytes.get buffer 2)) (Char.code (Lwt_bytes.get buffer 3)) end; test "NumberIO.BE.write_float32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.BE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) 66051. >|= fun () -> instrument (Lwt_bytes.to_string buffer = "\x47\x81\x01\x80") "NumberIO.BE.write_float32: %02X %02X %02X %02X" (Char.code (Lwt_bytes.get buffer 0)) (Char.code (Lwt_bytes.get buffer 1)) (Char.code (Lwt_bytes.get buffer 2)) (Char.code (Lwt_bytes.get buffer 3)) end; test "NumberIO.LE.write_float64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.LE.write_float64 (Lwt_io.(of_bytes ~mode:output) buffer) (Int64.float_of_bits 0x42F0203040506070L) >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x70\x60\x50\x40\x30\x20\xf0\x42") end; test "NumberIO.BE.write_float64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.BE.write_float64 (Lwt_io.(of_bytes ~mode:output) buffer) (Int64.float_of_bits 0x42F0203040506070L) >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x42\xf0\x20\x30\x40\x50\x60\x70") end; test "Write from Lwt_bytes" begin fun () -> let bytes = Lwt_bytes.of_string "Hello World" in let out = Lwt_bytes.create 11 in Lwt_io.write_from_exactly_bigstring (Lwt_io.(of_bytes ~mode:output) out) bytes 0 11 >>= fun () -> Lwt.return (Lwt_bytes.to_string out = "Hello World") end; test "Read from Lwt_bytes" begin fun () -> let bytes_in = Lwt_bytes.create 11 in let bytes = Lwt_bytes.of_string "Hello World" in Lwt_io.read_into_exactly_bigstring (Lwt_io.(of_bytes ~mode:input) bytes) bytes_in 0 11 >>= fun () -> Lwt.return (Lwt_bytes.to_string bytes_in = "Hello World") end; ]