Merge pull request xapi-project#5910 from edwintorok/private/edvint/e…

…poll-tests

tests for Unix.select and introduce select-as-epoll

ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune

@@ -1,7 +1,7 @@
 ; This will be used to test stdext itself, so do not depend on stdext here
 (library
 	(name xapi_fd_test)
-	(libraries (re_export xapi-stdext-unix.fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix)
+	(libraries clock (re_export xapi-stdext-unix.fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix)
 
 	; off by default, enable with --instrument-with bisect_ppx
 	(instrumentation (backend bisect_ppx))

ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml

@@ -28,11 +28,51 @@ let make ~size ~delay_read ~delay_write kind =
 
 open QCheck2
 
+let all_file_kinds = Unix.[S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK]
+
 let file_kind =
-  ( Gen.oneofa Unix.[|S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK|]
+  (* [Gen.oneofa] should be more efficient than [Gen.oneofl] *)
+  ( all_file_kinds |> Array.of_list |> Gen.oneofa
   , Print.contramap (Fmt.to_to_string Safefd.pp_kind) Print.string
   )
 
+let is_testable_kind = function
+  | Unix.(S_DIR | S_LNK) ->
+      (* unless you write a custom C binding, you cannot open these in OCaml *)
+      false
+  | Unix.S_BLK ->
+      Unix.geteuid () = 0
+  | Unix.(S_CHR | S_FIFO | S_REG | S_SOCK) ->
+      (* We cannot create new [S_CHR], but there are preexisting [S_CHR],
+         like [/dev/null]. *)
+      true
+
+let testable_file_kind =
+  ( all_file_kinds |> List.filter is_testable_kind |> Array.of_list |> Gen.oneofa
+  , snd file_kind
+  )
+
+let file_list gen =
+  let open Gen in
+  (* make sure we generate the empty list with ~50% probability,
+     and that we generate smaller lists more frequently
+  *)
+  let* size_bound = frequencya [|(4, 0); (4, 2); (2, 10); (1, 100)|] in
+  let size_gen = int_bound size_bound in
+  let repeated_list =
+    let* size = size_gen in
+    list_repeat size gen
+  in
+  (* generates 2 kinds of lists:
+     - lists that contain only a single file kind
+     - lists that contain multiple file kinds
+
+     This is important for testing [select], because a single
+       [Unix.S_REG] would cause it to return immediately,
+       making it unlikely that we're actually testing the behaviour for other file descriptors.
+  *)
+  oneof [repeated_list; list_size size_gen gen]
+
 (* also coincidentally the pipe buffer size on Linux *)
 let ocaml_unix_buffer_size = 65536
 
@@ -72,8 +112,12 @@ let delay_of_size total_delay size =
 let t =
   let open Gen in
   (* order matters here for shrinking: shrink timeout first so that shrinking completes sooner! *)
-  let* total_delay = total_delays and* size = sizes and* kind = fst file_kind in
+  let* total_delay = total_delays
+  and* size = sizes
+  and* kind = fst testable_file_kind in
+  let size = if kind = Unix.S_BLK then 512 else size in
   let* delay = delay_of_size total_delay size in
+  (* see observations.ml, we can't easily change size afterwards *)
   return @@ make ~delay_read:delay ~delay_write:delay ~size kind
 
 let print t =
@@ -140,3 +184,53 @@ let run_rw t data ~f =
         single_write_substring
   in
   observe_rw read write ~f t.kind ~size:t.size data
+
+let has_immediate_timeout = function
+  | Unix.S_FIFO | Unix.S_SOCK ->
+      false
+  | _ ->
+      true
+
+let select_fd_spec =
+  let open Gen in
+  let+ kind = fst testable_file_kind and+ wait = timeouts in
+  {kind; wait= (if has_immediate_timeout kind then 0. else wait)}
+
+let select_fd_spec_list = file_list select_fd_spec
+
+let is_rw_kind (t : select_fd_spec) =
+  match t.kind with Unix.S_SOCK | Unix.S_REG -> true | _ -> false
+
+let select_input_gen =
+  let open Gen in
+  let+ ro = select_fd_spec_list
+  and+ wo = select_fd_spec_list
+  and+ rw = select_fd_spec_list
+  and+ re = select_fd_spec_list
+  and+ we = select_fd_spec_list
+  and+ errors = select_fd_spec_list
+  and+ timeout = timeouts in
+  {
+    ro
+  ; wo
+  ; rw= List.filter is_rw_kind rw
+  ; re
+  ; we
+  ; errors= List.filter is_rw_kind errors
+  ; timeout
+  }
+
+let print_fd_spec =
+  let open Observations in
+  Print.contramap (fun t -> (t.kind, t.wait))
+  @@ Print.tup2 (snd file_kind) Print.float
+
+let print_fd_spec_list = Print.list print_fd_spec
+
+let select_input_print =
+  let to_tup t = (t.ro, t.wo, t.rw, t.re, t.we, t.errors, t.timeout) in
+  Print.contramap to_tup
+  @@ Print.tup7 print_fd_spec_list print_fd_spec_list print_fd_spec_list
+       print_fd_spec_list print_fd_spec_list print_fd_spec_list Print.float
+
+let select_input = (select_input_gen, select_input_print)

ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli

@@ -85,3 +85,23 @@ val run_rw :
 
  @returns observations about [f]'s actions the file descriptor
 *)
+
+val file_kind : Unix.file_kind QCheck2.Gen.t * Unix.file_kind QCheck2.Print.t
+(** [file_kind] is a {!type:Unix.file_kind} generator and pretty printer.
+  It generates all file kinds, even ones that normally cannot be opened in OCaml,
+  like {!val:Unix.S_DIR}, or that require special privileges, like {!val:Unix.S_BLK}
+
+  See also {!val:testable_file_kind}.
+ *)
+
+val testable_file_kind :
+  Unix.file_kind QCheck2.Gen.t * Unix.file_kind QCheck2.Print.t
+(** [testable_file_kind] is like {!val:file_kind}, but only generates file kinds
+  that the current program can create. *)
+
+val select_input :
+  Observations.select_input QCheck2.Gen.t
+  * Observations.select_input QCheck2.Print.t
+(** [select_input] generates input for [select/(e)poll].
+  See {!val:Observations.with_select_input} on how to use it to get actual file descriptors.
+ *)

ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml

@@ -7,6 +7,8 @@ let open_ro name = openfile_ro `reg name []
 
 let open_wo name = openfile_wo `reg name []
 
+let open_rw name = openfile_rw `reg name []
+
 let with_kind_ro kind f =
   let with2 t =
     let@ fd1, fd2 = with_fd2 t in
@@ -58,9 +60,7 @@ let with_kind_wo kind f =
   | Unix.S_LNK ->
       invalid_arg "S_LNK" (* O_NOFOLLOW not bound in OCaml *)
   | Unix.S_BLK ->
-      let@ name, out = with_tempfile () in
-      (* block device must have an initial size *)
-      ftruncate out 512L ;
+      let@ name, _out = with_tempfile ~size:512L () in
       let@ blkname, _ = with_temp_blk name in
       let@ fd_ro = with_fd @@ open_ro blkname in
       let@ fd = with_fd @@ open_wo blkname in
@@ -74,9 +74,13 @@ let with_kind_rw kind f =
   | Unix.S_SOCK ->
       let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
       f fd1 fd2
-  | Unix.S_FIFO | Unix.S_DIR | Unix.S_LNK | Unix.S_BLK | Unix.S_REG | Unix.S_CHR
-    ->
-      invalid_arg "not a socket"
+  | Unix.S_REG ->
+      let@ name, _out = with_tempfile () in
+      let@ fd = with_fd @@ open_rw name in
+      let@ fd' = with_fd @@ open_rw name in
+      f fd fd'
+  | Unix.S_FIFO | Unix.S_DIR | Unix.S_LNK | Unix.S_BLK | Unix.S_CHR ->
+      invalid_arg "with_kind_rw: not a socket or reg"
 
 let observe_read observed op t dest off len =
   let amount = op t dest off len in
@@ -309,3 +313,147 @@ let observe_rw read write ~f ~size kind expected =
     |> Option.map @@ fun write -> {write with data= Buffer.contents written}
   in
   ({read; write; elapsed}, res)
+
+let rec with_kind_list create aux f = function
+  | [] ->
+      f (List.rev aux)
+  | kind :: tl ->
+      create kind @@ fun fd1 fd2 ->
+      with_kind_list create ((fd1, fd2) :: aux) f tl
+
+let with_kind_list g lst f = with_kind_list g [] f lst
+
+let with_kinds_ro lst = with_kind_list with_kind_ro lst
+
+let with_kinds_wo lst = with_kind_list with_kind_wo lst
+
+(* compatible with [with_kind_ro] and [with_kind_wo] *)
+let with_kind_rw' kind f = with_kind_rw kind @@ fun fd1 fd2 -> f fd1 (Some fd2)
+
+let with_kinds_rw lst = with_kind_list with_kind_rw' lst
+
+type fd_set = Unix.file_descr list
+
+type select_fd_spec = {kind: Unix.file_kind; wait: float}
+
+type select_input = {
+    ro: select_fd_spec list
+  ; wo: select_fd_spec list
+  ; rw: select_fd_spec list
+  ; re: select_fd_spec list
+  ; we: select_fd_spec list
+  ; errors: select_fd_spec list
+  ; timeout: float
+}
+
+let split_combine gen lst f =
+  let fds, waits =
+    lst |> List.map (fun {kind; wait} -> (kind, wait)) |> List.split
+  in
+  gen fds @@ fun fds ->
+  let fds1, fds2 = List.split fds in
+  f (fds1, List.combine fds2 waits)
+
+let ( let@ ) f x = f x
+
+type 'a fd_safe_set = ('a, kind) make list
+
+let with_fd_inputs f (ro : rdonly fd_safe_set) (wo : wronly fd_safe_set)
+    (rw : rdwr fd_safe_set) (re : rdonly fd_safe_set) (we : wronly fd_safe_set)
+    (errs : rdwr fd_safe_set) timeout =
+  let ro = List.map For_test.unsafe_fd_exn ro
+  and wo = List.map For_test.unsafe_fd_exn wo
+  and re = List.map For_test.unsafe_fd_exn re
+  and we = List.map For_test.unsafe_fd_exn we
+  and rw = List.map For_test.unsafe_fd_exn rw
+  and errs = List.map For_test.unsafe_fd_exn errs in
+  let call timeout = f (ro @ rw @ re) (wo @ rw @ we) (errs @ re @ we) timeout in
+  let r1 = call timeout in
+  let r2 = call 0. in
+  (r1, r2)
+
+let simulate f lst lst' =
+  List.combine lst lst'
+  |> List.map @@ fun (wrapped, (wrapped', wait)) ->
+     (wait, For_test.unsafe_fd_exn wrapped, f wrapped wrapped')
+
+let large = String.make 1_000_000 'x'
+
+let buf = Bytes.make (String.length large) 'x'
+
+let simulate_ro _ro ro' () =
+  ro'
+  |> Option.iter @@ fun ro' ->
+     as_spipe_opt ro' |> Option.iter set_nonblock ;
+     let (_ : int) = Operations.single_write_substring ro' "." 0 1 in
+     ()
+
+let simulate_wo wo wo' =
+  let handle_pipe fd =
+    set_nonblock fd ;
+    (* fill buffers, to make write unavailable initially, but not on regular files/block devices,
+       to avoid ENOSPC errors
+    *)
+    let (_ : int) =
+      Operations.repeat_write Operations.single_write_substring fd large 0
+        (String.length large)
+    in
+    ()
+  in
+  as_spipe_opt wo |> Option.iter handle_pipe ;
+  fun () ->
+    wo'
+    |> Option.iter @@ fun wo' ->
+       as_spipe_opt wo' |> Option.iter set_nonblock ;
+       let (_ : int) = Operations.read wo' buf 0 (Bytes.length buf) in
+       ()
+
+let simulate_rw rw rw' =
+  let f = simulate_ro rw rw' and g = simulate_wo rw rw' in
+  fun () -> f () ; g ()
+
+let compare_wait (t1, _, _) (t2, _, _) = Float.compare t1 t2
+
+let run_simulation (stop, actions) =
+  (* TODO: measure when we actually sent, also have an atomic to when to stop exactly *)
+  List.fold_left
+    (fun (prev, fds) (curr, fd, action) ->
+      let delta = curr -. prev in
+      assert (delta >= 0.) ;
+      if not (Atomic.get stop) then
+        if delta > 0. then
+          Unix.sleepf delta ;
+      (* check again, might've been set meanwhile *)
+      ( curr
+      , if (not (Atomic.get stop)) || curr < Float.epsilon then (
+          action () ; fd :: fds
+        ) else
+          fds
+      )
+    )
+    (0., []) actions
+  |> snd
+
+let with_select_input t f =
+  let@ re, re' = split_combine with_kinds_ro t.re in
+  let@ we, we' = split_combine with_kinds_wo t.we in
+  let@ rw, rw' = split_combine with_kinds_rw t.rw in
+  let@ ro, ro' = split_combine with_kinds_ro t.ro in
+  let@ wo, wo' = split_combine with_kinds_wo t.wo in
+  let@ errs, errs' = split_combine with_kinds_rw t.errors in
+  let actions =
+    List.concat
+      [
+        simulate simulate_ro (ro @ re) (ro' @ re')
+      ; simulate simulate_wo (wo @ we) (wo' @ we')
+      ; simulate simulate_rw rw rw' (* TODO: how to simulate errors *)
+      ; simulate simulate_rw errs errs'
+      ]
+    |> List.fast_sort compare_wait
+  in
+  let stop = Atomic.make false in
+  let finally () = Atomic.set stop true in
+  let run () = with_fd_inputs f ro wo rw re we errs t.timeout in
+  let run () = Fun.protect ~finally run in
+  let r1, r2 = concurrently (run, run_simulation) ((), (stop, actions)) in
+  (unwrap_exn r1, unwrap_exn r2)