diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune index 146eadc9e0b..07ce09f8745 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune +++ b/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)) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml index 96cd2a897e6..5b89f8d73aa 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml +++ b/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) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli index 6aba67c7a6d..5fc4aedebdb 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli +++ b/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. + *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml index d9320234c38..57ae4e72496 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml +++ b/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) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli index 4300f5d56d7..5ba8a720251 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli @@ -28,6 +28,12 @@ val with_kind_ro : For character devices it receives a {!val:null} device. *) +val with_kinds_ro : + Unix.file_kind list + -> ((([> rdonly], kind) make * ([> writable], kind) make option) list -> 'a) + -> 'a +(** [with_kinds_ro kinds f] is like {!val:with_kind_ro} but for a list of file kinds. *) + val with_kind_wo : Unix.file_kind -> (([> wronly], kind) make -> ([> readable], kind) make option -> 'a) @@ -35,11 +41,24 @@ val with_kind_wo : (** [with_kind_wo kind f] is like {!val:with_kind_ro} but creates a write only file. *) +val with_kinds_wo : + Unix.file_kind list + -> ((([> wronly], kind) make * ([> readable], kind) make option) list -> 'a) + -> 'a +(** [with_kinds_wo kind f] is like {!val:with_kind_wo} but for a list of file kinds. *) + val with_kind_rw : Unix.file_kind -> (([> rdwr], kind) make -> ([> rdwr], kind) make -> 'a) -> 'a (** [with_kind_rw kind f] is like {!val:with_kind_ro} but creates a read-write file. *) +val with_kinds_rw : + Unix.file_kind list + -> ((([> rdwr], kind) make * ([> rdwr], kind) make option) list -> 'a) + -> 'a +(** [with_kinds_rw kind f] is like {!val:with_kind_rw} but for a list of file kinds. +*) + (** {1 Observe operations} *) val observe_read : @@ -203,3 +222,30 @@ val observe_rw : @param expected the string to write to the file descriptor @returns an observation of [f]'s actions on the file descriptor and [f]'s result *) + +type fd_set = Unix.file_descr list + +(** [select_fd_spec] defines a behaviour for a select input: a file descriptor kind and how long before any event happens on it *) +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 +} + +val with_select_input : + select_input + -> (fd_set -> fd_set -> fd_set -> float -> 'a) + -> ('a * 'a) * fd_set +(** [with_select_input behaviour f] creates file descriptors according to [behaviour] and calls [f] twice with it, + the 2nd time with a 0 timeout. + By the 2nd time it is called all the file descriptors from the available set should've been detected, + the 1st time you might run into a race condition where we've just sent the byte on the other end at the same time as the timeout. + + @returns the return value of [f], and a list of available file descriptors. + *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml index bce25cdcd03..f0f6e709e5e 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml @@ -58,6 +58,10 @@ let close t = Safefd.idempotent_close_exn t.fd let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) +let as_readable t = {t with props= as_readable t.props} + +let as_writable t = {t with props= as_writable t.props} + let as_readable_opt t = match as_readable_opt t.props with | None -> @@ -207,7 +211,7 @@ let with_tempfile ?size () f = try Unix.unlink name with Unix.Unix_error (_, _, _) -> () in let@ () = Fun.protect ~finally in - let t = ch |> Unix.descr_of_out_channel |> make_wo_exn `reg in + let t = ch |> Unix.descr_of_out_channel |> Unix.dup |> make_wo_exn `reg in let@ t = with_fd t in size |> Option.iter (fun size -> ftruncate t size) ; f (name, t) @@ -229,18 +233,8 @@ let check_output cmd args = | _ -> failwith (Printf.sprintf "%s exited nonzero" cmd) -let with_temp_blk ?(sector_size = 512) name f = - let blkdev = - check_output "losetup" - [ - "--show" - ; "--sector-size" - ; string_of_int sector_size - ; "--direct-io=on" - ; "--find" - ; name - ] - in +let with_temp_blk name f = + let blkdev = check_output "losetup" ["--show"; "--find"; name] in let custom_ftruncate size = Unix.LargeFile.truncate name size ; let (_ : string) = check_output "losetup" ["--set-capacity"; name] in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli index 6097f8cddf5..286e545321f 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli @@ -45,6 +45,14 @@ val setup : unit -> unit By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. *) +(** {1 Static property tests} *) + +val as_readable : (([< readable] as 'a), 'b) make -> ([> readable], 'b) make +(** [as_readable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_writable : ([< writable], 'b) make -> ([> writable], 'b) make +(** [as_writable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + (** {1 Runtime property tests} *) val as_readable_opt : @@ -246,8 +254,7 @@ val with_tempfile : (** [with_tempfile () f] calls [f (name, outfd)] with the name of a temporary file and a file descriptor opened for writing. Deletes the temporary file when [f] finishes. *) -val with_temp_blk : - ?sector_size:int -> string -> (string * ([> rdwr], [> blk]) make -> 'a) -> 'a +val with_temp_blk : string -> (string * ([> rdwr], [> blk]) make -> 'a) -> 'a (** [with_temp_blk ?sector_size path f] calls [f (name, fd)] with a name and file descriptor pointing to a block device. The block device is temporarily created on top of [path]. diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml index fa60e5f6682..bd8664e9c87 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml @@ -183,13 +183,13 @@ let test_sock_shutdown_all () = let@ () = Alcotest.check_raises "write after shutdown" exn in write_fd fd1 -let test_block sector_size = +let test_block () = let with_make () f = let@ name, fd = with_tempfile () in ftruncate fd 8192L ; let run () = try - let@ _blkname, fd = with_temp_blk ~sector_size name in + let@ _blkname, fd = with_temp_blk name in f fd with Failure _ -> let bt = Printexc.get_raw_backtrace () in @@ -204,19 +204,6 @@ let test_block sector_size = test_fd with_make [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] -let test_block_nest = - let with_make () f = - if Unix.geteuid () <> 0 then - Alcotest.skip () ; - let@ name, fd = with_tempfile () in - ftruncate fd 8192L ; - let@ blkname, _fd = with_temp_blk ~sector_size:4096 name in - let@ _blkname, fd = with_temp_blk ~sector_size:512 blkname in - f fd - in - test_fd with_make - [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] - let test_creat () = let name = Filename.temp_file __MODULE__ (Unix.getpid () |> string_of_int) in Unix.unlink name ; @@ -295,9 +282,7 @@ let () = ("pipe", test_pipe) ; ("socket", test_sock) ; ("regular", test_regular) - ; ("block 512", test_block 512) - ; ("block 4k", test_block 4096) - ; ("block 512 on 4k", test_block_nest) + ; ("block", test_block ()) ; ("xapi_fdcaps", tests) ; ("no fd leaks", [Alcotest.test_case "no leaks" `Quick test_no_leaks]) ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index b255239dd4d..1ca5e916ef4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -111,3 +111,23 @@ module Delay = struct (* If the wait hasn't happened yet then store up the signal *) ) end + +let wait_timed_read fd timeout = + match Xapi_stdext_unix.Unixext.select [fd] [] [] timeout with + | [], _, _ -> + false + | [fd'], _, _ -> + assert (fd' = fd) ; + true + | _ -> + assert false + +let wait_timed_write fd timeout = + match Xapi_stdext_unix.Unixext.select [] [fd] [] timeout with + | _, [], _ -> + false + | _, [fd'], _ -> + assert (fd' = fd) ; + true + | _ -> + assert false diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli index 8349ab71366..057aedfa700 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli @@ -33,3 +33,7 @@ module Delay : sig val signal : t -> unit (** Sends a signal to a waiting thread. See 'wait' *) end + +val wait_timed_read : Unix.file_descr -> float -> bool + +val wait_timed_write : Unix.file_descr -> float -> bool diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 0eb42f9d114..3b116a07983 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,7 +1,7 @@ (library (name unixext_test) (modules unixext_test) - (libraries xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) + (libraries clock xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) ) (test diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index 656dcc1fe56..83bc7f00bd2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -39,11 +39,23 @@ let pp_pair = ) *) +let skip_blk_timed behaviour = + let open Generate in + (* select/poll on block device returns immediately, + so we cannot apply any delays on the reads/writes: + they won't be reflected on the other side yet + *) + QCheck2.assume + (behaviour.kind <> Unix.S_BLK + || Option.is_none behaviour.delay_write + && Option.is_none behaviour.delay_read + ) + let test_time_limited_write = let gen = Gen.tup2 Generate.t Generate.timeouts and print = Print.tup2 Generate.print Print.float in Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> - skip_blk behaviour.kind ; + skip_blk_timed behaviour ; skip_dirlnk behaviour.kind ; try let test_elapsed = ref Mtime.Span.zero in @@ -60,7 +72,6 @@ let test_time_limited_write = ) ; buf in - (*Printf.eprintf "testing write: %s\n%!" (print (behaviour, timeout)) ;*) let observations, result = Generate.run_wo behaviour ~f:test in let () = let open Observations in @@ -105,9 +116,9 @@ let test_time_limited_read = let gen = Gen.tup2 Generate.t Generate.timeouts and print = Print.tup2 Generate.print Print.float in Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> - (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) skip_blk behaviour.kind ; skip_dirlnk behaviour.kind ; + skip_blk_timed behaviour ; let test_elapsed = ref Mtime.Span.zero in let test wrapped_fd = let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in @@ -119,7 +130,6 @@ let test_time_limited_read = Unixext.time_limited_read fd behaviour.size deadline ) in - (*Printf.eprintf "testing: %s\n%!" (print (behaviour, timeout)) ;*) let observations, result = let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in Generate.run_ro behaviour buf ~f:test @@ -132,7 +142,6 @@ let test_time_limited_read = "Function duration significantly exceeds timeout: %f > %f; %s" elapsed_s timeout (Fmt.to_to_string Fmt.(option pp) observations.Observations.write) ; - (* Format.eprintf "Result: %a@." (Fmt.option Observations.pp) observations.write;*) match (observations, result) with | {write= Some write; _}, Ok actual -> expect_amount ~expected:(String.length actual) write ; @@ -187,7 +196,92 @@ let test_proxy = expect_string ~expected:write.data ~actual:read.data ; true -let tests = [test_proxy; test_time_limited_write; test_time_limited_read] +let run_select ro wo errs timeout = + let dt = Mtime_clock.counter () in + let r = Unixext.select ro wo errs timeout in + (Mtime_clock.count dt, timeout, r) + +(* delays as long as 28.4ms were observed with epoll + (on an otherwise idle system with a single thread, and no Xen domains) + Be very conservative here and allow for a large difference +*) +let extra_timeout = Mtime.Span.(250 * ms) + +let check_timeout elapsed timeout = + let timeout_span = Clock.Timer.s_to_span timeout |> Option.get in + if + Clock.Timer.span_is_longer elapsed + ~than:(Mtime.Span.add Mtime.Span.(2 * timeout_span) extra_timeout) + then + Test.fail_reportf "Timed out too late: %a > %f" Mtime.Span.pp elapsed + timeout ; + timeout_span + +module FDSet = Set.Make (struct + type t = Unix.file_descr + + let compare = Stdlib.compare +end) + +let check_set lst = + let set = FDSet.of_list lst in + let n = List.length lst and n' = FDSet.cardinal set in + if n <> n' then + Test.fail_reportf + "File descriptor set contains duplicate elements: %d <> %d" n n' ; + set + +let check_sets (s1, s2, s3) = (check_set s1, check_set s2, check_set s3) + +let pp_fd = Fmt.using Unixext.int_of_file_descr Fmt.int + +let pp_fdset = Fmt.(using FDSet.to_seq @@ Dump.seq pp_fd) + +let check_subset msg msg' s1 s1' (r, w, e) (r', w', e') = + if not (FDSet.subset s1 s1') then + Test.fail_reportf + "%s %s: (%d and %d elements): %a and %a. output: %a,%a,%a; available: \ + %a,%a,%a" + msg msg' (FDSet.cardinal s1) (FDSet.cardinal s1') pp_fdset s1 pp_fdset s1' + pp_fdset r pp_fdset w pp_fdset e pp_fdset r' pp_fdset w' pp_fdset e' + +let check_subsets msg ((s1, s2, s3) as all) ((s1', s2', s3') as all') = + check_subset msg "read" s1 s1' all all' ; + check_subset msg "write" s2 s2' all all' ; + check_subset msg "error" s3 s3' all all' + +let test_select = + let gen, print = Generate.select_input in + Test.make ~long_factor:10 ~name:__FUNCTION__ ~print gen @@ fun t -> + (* epoll raised EEXIST, but none of the actual callers in XAPI need this, + so skip + *) + QCheck2.assume (t.rw = [] && t.re = [] && t.we = []) ; + let ((elapsed, timeout, ready), (elapsed', timeout', ready')), available = + Observations.with_select_input t run_select + in + let timeout_span = check_timeout elapsed timeout in + let (_ : Mtime.Span.t) = check_timeout elapsed' timeout' in + let () = + match ready with + | [], [], [] -> + if Clock.Timer.span_is_shorter elapsed ~than:timeout_span then + Test.fail_reportf "Timed out too early: %a < %f" Mtime.Span.pp elapsed + timeout + | _ -> + let ready = check_sets ready in + let ready' = check_sets ready' in + let available = check_set available in + let available = (available, available, available) in + check_subsets "1st call subset of 2nd" ready ready' ; + check_subsets "ready subset of available" ready available ; + check_subsets "ready' subset of available" ready' available ; + () + in + true + +let tests = + [test_select; test_proxy; test_time_limited_write; test_time_limited_read] let () = (* avoid SIGPIPE *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 5141e888fe8..7fee8112b4e 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -672,6 +672,77 @@ let time_limited_single_read filedesc length ~max_wait = in Bytes.sub_string buf 0 bytes +(** see [select(2)] "Correspondence between select() and poll() notifications". + Note that HUP and ERR are ignored in events and returned only in revents. + For simplicity we use the same event mask from the manual in both cases + *) +let pollin_set = Polly.Events.(rdnorm lor rdband lor inp lor hup lor err) + +let pollout_set = Polly.Events.(wrband lor wrnorm lor out lor err) + +let pollerr_set = Polly.Events.pri + +let to_milliseconds ms = ms *. 1e3 |> ceil |> int_of_float + +(* we could change lists to proper Sets once the Unix.select to Unixext.select conversion is done *) + +let readable fd (rd, wr, ex) = (fd :: rd, wr, ex) + +let writable fd (rd, wr, ex) = (rd, fd :: wr, ex) + +let error fd (rd, wr, ex) = (rd, wr, fd :: ex) + +let check_events fd mask event action state = + if Polly.Events.test mask event then + action fd state + else + state + +let no_events = ([], [], []) + +let fold_events _ fd event state = + state + |> check_events fd pollin_set event readable + |> check_events fd pollout_set event writable + |> check_events fd pollerr_set event error + +let polly_fold_add polly events action immediate fd = + try Polly.add polly fd events ; immediate + with Unix.Unix_error (Unix.EPERM, _, _) -> + (* matches the behaviour of select: file descriptors that cannot be watched + are returned as ready immediately *) + action fd immediate + +let polly_fold polly events fds action immediate = + List.fold_left (polly_fold_add polly events action) immediate fds + +let select ins outs errs timeout = + (* -1.0 is a special value used in forkexecd *) + if timeout < 0. && timeout <> -1.0 then + invalid_arg (Printf.sprintf "negative timeout would hang: %g" timeout) ; + match (ins, outs, errs) with + | [], [], [] -> + Unix.sleepf timeout ; no_events + | _ -> ( + with_polly @@ fun polly -> + (* file descriptors that cannot be watched by epoll *) + let immediate = + no_events + |> polly_fold polly pollin_set ins readable + |> polly_fold polly pollout_set outs writable + |> polly_fold polly pollerr_set errs error + in + match immediate with + | [], [], [] -> + Polly.wait_fold polly 1024 (to_milliseconds timeout) no_events + fold_events + | _ -> + (* we have some fds that are immediately available, but still poll the others + for any events that are available immediately + *) + Polly.wait_fold polly 1024 0 immediate fold_events + ) + (* --------------------------------------------------------------------------------------- *) (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index 176adc94cf8..0d3bc48abc9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -156,6 +156,13 @@ val time_limited_read : Unix.file_descr -> int -> float -> string val time_limited_single_read : Unix.file_descr -> int -> max_wait:float -> string +val select : + Unix.file_descr list + -> Unix.file_descr list + -> Unix.file_descr list + -> float + -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list + val read_data_in_string_chunks : (string -> int -> unit) -> ?block_size:int diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 390ccb9ae66..9a8a4a75043 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -20,6 +20,7 @@ rpclib.core rrdd_libs stunnel + unixext_test bufio_test test_timer threads.posix diff --git a/ocaml/quicktest/quicktest b/ocaml/quicktest/quicktest index c9e0d2de1f5..89fa7927fef 100644 --- a/ocaml/quicktest/quicktest +++ b/ocaml/quicktest/quicktest @@ -1,4 +1,5 @@ #!/bin/bash +ulimit -n 2048 # Run quicktest with support for exception backtraces. OCAMLRUNPARAM=b "@OPTDIR@/debug/quicktestbin" "$@" diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index 563ba4a88ba..38a139666ae 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -15,7 +15,11 @@ (** The main entry point of the quicktest executable *) let qchecks = - [("bufio", Bufio_test.tests); ("Timer", Test_timer.tests)] + [ + ("unixext", Unixext_test.tests) + ; ("bufio", Bufio_test.tests) + ; ("Timer", Test_timer.tests) + ] |> List.map @@ fun (name, test) -> (name, List.map QCheck_alcotest.(to_alcotest ~long:true) test) @@ -44,16 +48,16 @@ let () = ; ("Quicktest_date", Quicktest_date.tests ()) ; ("Quicktest_crypt_r", Quicktest_crypt_r.tests ()) ] + @ ( if not !Quicktest_args.using_unix_domain_socket then + [("http", Quicktest_http.tests)] + else + [] + ) @ - if not !Quicktest_args.using_unix_domain_socket then - [("http", Quicktest_http.tests)] + if not !Quicktest_args.skip_stress then + qchecks else [] - @ - if not !Quicktest_args.skip_stress then - qchecks - else - [] in (* Only list tests if asked, without running them *) if !Quicktest_args.list_tests then