Merge pull request #5838 from edwintorok/private/edvint/fix-timeouts

Fix @StressTest failure

Author: edwintorok

ocaml/libs/http-lib/bufio_test.ml

@@ -21,7 +21,30 @@ let test_buf_io =
   let gen = Gen.tup2 Generate.t timeouts
   and print = Print.tup2 Generate.print print_timeout in
   Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) ->
+  let every_bytes =
+    Int.min
+      (Option.map Observations.Delay.every_bytes behaviour.delay_read
+      |> Option.value ~default:Int.max_int
+      )
+      (Option.map Observations.Delay.every_bytes behaviour.delay_write
+      |> Option.value ~default:Int.max_int
+      )
+  in
+  let operations = Int.max 1 (behaviour.size / every_bytes) in
+  (* Buf_io uses per-operation timeouts, not a timeout for the whole function,
+     so if we want a timeout of 0.1s and we insert some delays every 1 byte,
+     for 64KiB bytes in total, then we need 0.1/65536 timeout for individual operations.
+
+     timeout_span remains the span for the entire function,
+     and timeout the per operation timeout that we'll pass to the function under test.
+  *)
   let timeout_span = Mtime.Span.of_float_ns (timeout *. 1e9) |> Option.get in
+  let timeout = timeout /. float operations in
+  let timeout_operation_span =
+    Mtime.Span.of_float_ns (timeout *. 1e9) |> Option.get
+  in
+  (* timeout < 1us would get truncated to 0 *)
+  QCheck2.assume (timeout > 1e-6) ;
   (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *)
   if behaviour.kind <> Unix.S_SOCK then
     QCheck2.assume_fail () ;
@@ -59,7 +82,7 @@ let test_buf_io =
         expect_string ~expected:write.data ~actual
     | {write= Some _; _}, Error (`Exn_trap (Buf_io.Timeout, _)) ->
         let elapsed = !test_elapsed in
-        if Mtime.Span.compare elapsed timeout_span < 0 then
+        if Mtime.Span.compare elapsed timeout_operation_span < 0 then
           Test.fail_reportf "Timed out earlier than requested: %a < %a"
             Mtime.Span.pp elapsed Mtime.Span.pp timeout_span
     | ( {write= Some write; _}

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

@@ -62,8 +62,12 @@ let delay_of_size total_delay size =
   let open Gen in
   let* every_bytes = if size = 0 then return 1 else 1 -- size in
   let chunks = max 1 (size / every_bytes) in
-  let duration = total_delay /. float_of_int chunks |> span_of_s in
-  return @@ Some (Delay.v ~every_bytes ~duration)
+  let duration = total_delay /. float_of_int chunks in
+  if duration < 1e-6 then
+    return None
+  else
+    let duration = duration |> span_of_s in
+    return @@ Some (Delay.v ~every_bytes ~duration)
 
 let t =
   let open Gen in

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

@@ -158,7 +158,9 @@ module CancellableSleep = struct
       ; buf= Bytes.make 1 ' '
       }
 
-  let set_rcvtimeo sock timeo = setsockopt_float sock Unix.SO_RCVTIMEO timeo
+  let set_rcvtimeo sock timeo =
+    if timeo < 1e-6 then Fmt.invalid_arg "timeout too short: %g" timeo ;
+    setsockopt_float sock Unix.SO_RCVTIMEO timeo
 
   let sleep t dt =
     set_rcvtimeo t.wait (Mtime.Span.to_float_ns dt *. 1e-9) ;
@@ -173,6 +175,8 @@ end
 module Delay = struct
   type t = {duration: Mtime.span; every_bytes: int}
 
+  let every_bytes t = t.every_bytes
+
   let pp =
     Fmt.(
       record ~sep:(any ";")

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

@@ -109,6 +109,9 @@ module Delay : sig
     Note that the time taken to send or receive [after_bytes] is not taken into account to guarantee the insertion of the delay.
   *)
 
+  val every_bytes : t -> int
+  (** [every_bytes t] is how often delays are inserted *)
+
   val apply_read :
        CancellableSleep.t
     -> t