File: test_lwt_io.ml

package info (click to toggle)
lwt 2.7.1-4
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 2,452 kB
  • ctags: 3,684
  • sloc: ml: 25,116; ansic: 4,725; makefile: 82
file content (423 lines) | stat: -rw-r--r-- 14,901 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
(* Lightweight thread library for OCaml
 * http://www.ocsigen.org/lwt
 * Module Test_lwt_io
 * Copyright (C) 2009 Jérémie Dimino
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as
 * published by the Free Software Foundation, with linking exceptions;
 * either version 2.1 of the License, or (at your option) any later
 * version. See COPYING file for details.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 * 02111-1307, USA.
 *)

open Test
open Lwt.Infix

let with_async_exception_hook hook f =
  let old_hook = !Lwt.async_exception_hook in
  Lwt.async_exception_hook := hook;
  f () >|= fun v ->
  Lwt.async_exception_hook := old_hook;
  v

let local = Unix.ADDR_INET (Unix.inet_addr_loopback, 4321)

(* Helpers for [establish_server_2] tests. *)
module Establish_server =
struct
  let with_client f =
    let handler_finished, notify_handler_finished = Lwt.wait () in

    Lwt_io.Versioned.establish_server_2
      local
      (fun 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.Versioned.shutdown_server_2 server

  (* Dirty hack for forcing [Lwt_io.close] to fail, to test response to [close]
     exceptions. Impolitely closes the [n]th last file descriptor allocated by
     the system, without going through [Lwt_io].

     This assumes that the system allocates contiguously-increasing file
     descriptors whenever possible, and can only be "correctly" done due to
     exact control of file descriptors during testing.

     The reasons for writing this are as follows:
     - [EBADF] is the only error we can reliably produce on [close].
     - This requires a closed file descriptor.
     - If we go through [Lwt_io] to close twice, it will not run the second
       [close] operation, but simply return the result of the first.
     - The [Lwt_io] interface does not allow retrieving a file descriptor from a
       channel.
     - Indeed, channels are not, in general, associated with file descriptors,
       and the file descriptors for channels that are, are floating in closures.
       So, there is no internal state that can be easily exposed to get the file
       descriptor, even when there is one.

     This may not work on some systems, so the corresponding tests will have to
     be disabled. *)
  let close_last_fd n =
    let guess_fd () =
      (* Using a pipe because it is easy and has no file system consequences. *)
      let fd1, fd2 = Unix.pipe () in
      Unix.close fd1;
      Unix.close fd2;

      (* Make it possible to do arithmetic on file descriptors. Dreams can come
         true! *)
      let
        module Pierce_abstraction =
        struct
          external pierce_fd : Unix.file_descr -> int = "%identity"
          external hide_fd : int -> Unix.file_descr = "%identity"
        end
      in

      let fd1, fd2 = Pierce_abstraction.(pierce_fd fd1, pierce_fd fd2) in
      let lowest = min fd1 fd2 in
      let fd = lowest - n in
      Pierce_abstraction.hide_fd fd
    in

    Unix.close (guess_fd ())

  (* 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"
    (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
         Lwt.return false
       else
         Lwt_unix.yield () >>= fun () ->
         Lwt.return (!sent = [Bytes.of_string "foobar"]));

  test "auto-flush in atomic"
    (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
              Lwt.return false
            else
              Lwt_unix.yield () >>= fun () ->
              Lwt.return (!sent = [Bytes.of_string "foobar"]))
         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"
    (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 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.Versioned.shutdown_server_2 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 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.Versioned.shutdown_server_2 server >|= fun () ->
      result);

  test "establish_server_2: 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 "establish_server_2: 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_2: 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);

  (* Screws up the open sockets so that shutdown or close results in EBADF.
     Then, closes the channels and observes the expected exceptions. Then,
     allows the implicit closing code to run. If this code tries to close the
     sockets again, the exception will go to Lwt.async_exception_hook and kill
     the tester. The correct behavior is for implicit close to do nothing if the
     user already tried to close the sockets. *)
  test "establish_server_2: no duplicate exceptions"
    ~only_if:(fun () -> not Sys.win32)
    (fun () ->
      let open Establish_server in

      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.fail exn) [@ocaml.warning "-4"]
      in

      let run =
        Establish_server.with_client
          (fun (in_channel, out_channel) ->
            close_last_fd 1;
            expecting_ebadf (fun () -> Lwt_io.close in_channel) >>= fun () ->
            expecting_ebadf (fun () -> Lwt_io.close out_channel))
      in

      run >|= fun () ->
      !exceptions_observed = 2);

(*
  (* Screws up the open sockets so closing them fails with EBADF. Then, raises
     an exception from the handler. Checks that the handler exception arrives
     at Lwt.async_exception_hook before the exceptions from implicit close. *)
  test "establish_server_2: order of exceptions"
    ~only_if:(fun () -> not Sys.win32)
    (fun () ->
      let open Establish_server in

      let exceptions_observed = ref 0 in
      let correct_exceptions = ref true in
      let see_exception exn =
        exceptions_observed := !exceptions_observed + 1;
        (match !exceptions_observed, exn with
        | 1, Exit
        | (2 | 3), Unix.Unix_error (Unix.EBADF, _, _) -> ()
        | _ -> correct_exceptions := false) [@ocaml.warning "-4"]
      in

      let run () =
        Establish_server.with_client
          (fun (_in_channel, _out_channel) ->
            close_last_fd 1;
            raise Exit)
      in

      with_async_exception_hook see_exception run >|= fun () ->
      !exceptions_observed = 3 && !correct_exceptions);
*)

  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

      Lwt_io.Versioned.establish_server_2 local (fun _ -> 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.Versioned.shutdown_server_2 server >>= fun () ->
      is_closed_in !in_channel' >>= fun in_closed ->
      is_closed_out !out_channel' >|= fun out_closed ->
      in_closed && out_closed);

  (* Makes the socket fail with EBADF on close. Tries to close the socket
     manually, and handles the exception. When with_connection tries to close
     the socket again implicitly, that should not raise the exception again. *)
  test "with_connection: no duplicate exceptions"
    ~only_if:(fun () -> not Sys.win32)
    (fun () ->
      let open Establish_server in

      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.fail exn) [@ocaml.warning "-4"]
      in

      let handler_started, notify_handler_started = Lwt.wait () in
      let finish_server, resume_server = Lwt.wait () in
      Lwt_io.Versioned.establish_server_2 local
        (fun _ ->
          Lwt.wakeup notify_handler_started ();
          finish_server) >>= fun server ->

      expecting_ebadf (fun () ->
        Lwt_io.with_connection local (fun (in_channel, out_channel) ->
          handler_started >>= fun () ->
          close_last_fd 2;
          expecting_ebadf (fun () -> Lwt_io.close in_channel) >>= fun () ->
          expecting_ebadf (fun () -> Lwt_io.close out_channel)))

      >>= fun () ->
      Lwt.wakeup resume_server ();
      Lwt_io.Versioned.shutdown_server_2 server >|= fun () ->
      !exceptions_observed = 2);
]