From d5b362330bdd724efd9204fb490ec38c49432110 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 13:21:56 +0100
Subject: [PATCH 01/13] Quicktest: actually run the quickcheck tests too
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Parenthesis were in the wrong place, so when you ran just the non-XAPI tests by hand it worked,
but when running all tests automatically it skipped the qcheck tests.

I'm fairly sure I fixed this bug previously, but must've gotten lost during a rebase.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 ocaml/quicktest/quicktest.ml | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml
index 563ba4a88ba..48bfc34c998 100644
--- a/ocaml/quicktest/quicktest.ml
+++ b/ocaml/quicktest/quicktest.ml
@@ -44,16 +44,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

From ac485b4cc22646b004e771b7824496c6d6dee7f8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:36:12 +0100
Subject: [PATCH 02/13] xapi-fd-test: fix compatibility with old losetup
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The version we have in Dom0 is too old and doesn't support these flags.
We can only test 512 block size.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../lib/xapi-fd-test/observations.ml          |  4 +---
 .../xapi-stdext/lib/xapi-fdcaps/operations.ml | 14 ++-----------
 .../lib/xapi-fdcaps/operations.mli            |  3 +--
 .../lib/xapi-fdcaps/test/test_operations.ml   | 21 +++----------------
 4 files changed, 7 insertions(+), 35 deletions(-)

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..3129b06ce53 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml
@@ -58,9 +58,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
diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml
index bce25cdcd03..d5db8210aa4 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml
@@ -229,18 +229,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..cf65b2aab68 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli
@@ -246,8 +246,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])
     ]

From 79b81dcebb055f6698a09c2f87e690e222c662c5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:36:55 +0100
Subject: [PATCH 03/13] xapi-fd-test: fix BLK tests
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

These only run when root.

However certain combinations are not valid: we cannot insert delays when reading/writing,
because the other side won't get any completion notifications, so we cannot check the usual
way whether time_limited_{read,write} has completed.

Skip BLK tests with delays.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../lib/xapi-stdext-unix/test/unixext_test.ml     | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 1 deletion(-)

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..95d00f421d8 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
@@ -108,6 +120,7 @@ let test_time_limited_read =
   (* 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

From 8f89e63b1c28f4ad27a3030a84add4505466a37a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:46:04 +0100
Subject: [PATCH 04/13] xapi-fd-test: fix BLK EBADF
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The file descriptor gets closed when the channel is closed, so we need to use Unix.dup here
to avoid a double close and avoid an EBADF.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml
index d5db8210aa4..5e5ec0572dc 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml
@@ -207,7 +207,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)

From 2bf0dd6c65be8285ec3a6999c7e1512684f71b16 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 10:28:41 +0100
Subject: [PATCH 05/13] Quicktest: add unixext_test
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

And increase ulimit when running quicktest, to cope with open-1024 on startup.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 ocaml/quicktest/dune         | 1 +
 ocaml/quicktest/quicktest    | 1 +
 ocaml/quicktest/quicktest.ml | 6 +++++-
 3 files changed, 7 insertions(+), 1 deletion(-)

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 48bfc34c998..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)
 

From ccd819754bb1be0abd2711ca0b889420b59472c9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 29 Jul 2024 22:26:41 +0100
Subject: [PATCH 06/13] xapi_fd_test: introduce testable_file_kind
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Like file_kind, but exclude file kinds that the current program cannot generate,
e.g. exclude block devices when not root.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../xapi-stdext/lib/xapi-fd-test/generate.ml  | 27 +++++++++++++++++--
 .../xapi-stdext/lib/xapi-fd-test/generate.mli | 13 +++++++++
 2 files changed, 38 insertions(+), 2 deletions(-)

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..355f220e383 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,30 @@ 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
+  )
+
 (* also coincidentally the pipe buffer size on Linux *)
 let ocaml_unix_buffer_size = 65536
 
@@ -72,8 +91,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 =
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..f403dc9d025 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,16 @@ 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. *)

From aaec96d961de687f78fd401853f1b41f641d6b98 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 29 Jul 2024 22:43:46 +0100
Subject: [PATCH 07/13] xapi-fd-test: introduce with kind list
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Generate a list of file descriptors, with nested try/finally closing.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../lib/xapi-fd-test/observations.ml          | 15 +++++++++++++++
 .../lib/xapi-fd-test/observations.mli         | 19 +++++++++++++++++++
 2 files changed, 34 insertions(+)

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 3129b06ce53..3e729551c99 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml
@@ -307,3 +307,18 @@ 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
+
+let with_kinds_rw lst = with_kind_list with_kind_rw lst
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..412e8fd8c07 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) 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 :

From 60a47d4a273547f554da98039f4f23e566defb50 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:45:51 +0100
Subject: [PATCH 08/13] xapi-fd-test: introduce testable_file_kinds
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../xapi-stdext/lib/xapi-fd-test/generate.ml  | 22 +++++++++++++++++++
 .../xapi-stdext/lib/xapi-fd-test/generate.mli |  3 +++
 2 files changed, 25 insertions(+)

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 355f220e383..3292296aa04 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml
@@ -52,6 +52,28 @@ let testable_file_kind =
   , snd file_kind
   )
 
+let testable_file_kinds =
+  let f, _ = testable_file_kind in
+  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, 510)|] in
+  let size_gen = int_bound size_bound in
+  let repeated_list =
+    let* size = size_gen in
+    list_repeat size f
+  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 f]
+
 (* also coincidentally the pipe buffer size on Linux *)
 let ocaml_unix_buffer_size = 65536
 
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 f403dc9d025..2186e83ae04 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli
@@ -98,3 +98,6 @@ 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 testable_file_kinds : Unix.file_kind list QCheck2.Gen.t
+(** [testable_file_kinds] generates multiple file kinds, suitable for [select/poll/epoll]. *)

From 592cc2d909068372974888eeca0170bf25674da5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:48:35 +0100
Subject: [PATCH 09/13] xapi-fd-test: generate inputs for select
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Generate 3 sets of file descriptors and a timeout.

Try to generate interesting combinations:
* empty lists
* lists with the same file kinds
* lists with mixed file kinds
* lists with common elements
* bias towards generating very short lists

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune  |   2 +-
 .../xapi-stdext/lib/xapi-fd-test/generate.ml  |  59 +++++++-
 .../xapi-stdext/lib/xapi-fd-test/generate.mli |   8 +-
 .../lib/xapi-fd-test/observations.ml          | 143 +++++++++++++++++-
 .../lib/xapi-fd-test/observations.mli         |  29 +++-
 .../xapi-stdext/lib/xapi-fdcaps/operations.ml |   4 +
 .../lib/xapi-fdcaps/operations.mli            |   8 +
 7 files changed, 240 insertions(+), 13 deletions(-)

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 3292296aa04..5b89f8d73aa 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml
@@ -52,17 +52,16 @@ let testable_file_kind =
   , snd file_kind
   )
 
-let testable_file_kinds =
-  let f, _ = testable_file_kind in
+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, 510)|] in
+  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 f
+    list_repeat size gen
   in
   (* generates 2 kinds of lists:
      - lists that contain only a single file kind
@@ -72,7 +71,7 @@ let testable_file_kinds =
        [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 f]
+  oneof [repeated_list; list_size size_gen gen]
 
 (* also coincidentally the pipe buffer size on Linux *)
 let ocaml_unix_buffer_size = 65536
@@ -185,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 2186e83ae04..5fc4aedebdb 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli
@@ -99,5 +99,9 @@ val testable_file_kind :
 (** [testable_file_kind] is like {!val:file_kind}, but only generates file kinds
   that the current program can create. *)
 
-val testable_file_kinds : Unix.file_kind list QCheck2.Gen.t
-(** [testable_file_kinds] generates multiple file kinds, suitable for [select/poll/epoll]. *)
+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 3e729551c99..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
@@ -72,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
@@ -321,4 +327,133 @@ let with_kinds_ro lst = with_kind_list with_kind_ro lst
 
 let with_kinds_wo lst = with_kind_list with_kind_wo lst
 
-let with_kinds_rw lst = with_kind_list with_kind_rw 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 412e8fd8c07..5ba8a720251 100644
--- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli
+++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli
@@ -54,7 +54,7 @@ val with_kind_rw :
 
 val with_kinds_rw :
      Unix.file_kind list
-  -> ((([> rdwr], kind) make * ([> rdwr], kind) make) list -> 'a)
+  -> ((([> 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.
 *)
@@ -222,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 5e5ec0572dc..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 ->
diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli
index cf65b2aab68..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 :

From a5ce54d00934125d3bbfbc3be4d07d785de88bd4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:49:54 +0100
Subject: [PATCH 10/13] unixext_test: add test for select
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Test Unix.select.
This can be easily switched to test Unixext.select based on epoll.

We disable the 'open 1024' fds on startup because we are testing regular select here.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../lib/xapi-stdext-unix/test/dune            |  2 +-
 .../lib/xapi-stdext-unix/test/unixext_test.ml | 94 +++++++++++++++++--
 2 files changed, 89 insertions(+), 7 deletions(-)

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 95d00f421d8..b3cd441c2ef 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
@@ -72,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
@@ -117,7 +116,6 @@ 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 ;
@@ -132,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
@@ -145,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 ;
@@ -200,9 +196,95 @@ 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 = Unix.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 *)
   let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in
-  Xapi_stdext_unix.Unixext.test_open 1024
+  (* Reenable this on the epoll branch: Xapi_stdext_unix.Unixext.test_open 1024 *)
+  ()

From d9d30014e3d63813257cafe6ae972ebec1748810 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Thu, 18 Jul 2024 18:35:39 +0100
Subject: [PATCH 11/13] CP-32622: introduce select-as-epoll in Unixext
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

A drop-in replacement for select that doesn't fail when a file descriptor number is >1024.

This is bad for performance (it makes a lot more syscalls than select),
and performance sensitive callers should instead use `SO_RCVTIMEO/SO_SNDTIMEO` on sockets,
or move the polly instance creation out of loops.

This will also use one additional file descriptor compared to 'select', so it will reach EMFILE sooner.
When replacing `Unix.select` with `Unixext.select` you must also increase resource limits!

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../lib/xapi-stdext-unix/unixext.ml           | 71 +++++++++++++++++++
 .../lib/xapi-stdext-unix/unixext.mli          |  7 ++
 2 files changed, 78 insertions(+)

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

From 5b756b252f3c50414f3e76ac03864b89e78548a9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 5 Aug 2024 09:56:06 +0100
Subject: [PATCH 12/13] xapi-fd-test: switch to testing Unixext.select
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml    | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

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 b3cd441c2ef..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
@@ -198,7 +198,7 @@ let test_proxy =
 
 let run_select ro wo errs timeout =
   let dt = Mtime_clock.counter () in
-  let r = Unix.select ro wo errs timeout 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
@@ -286,5 +286,4 @@ let tests =
 let () =
   (* avoid SIGPIPE *)
   let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in
-  (* Reenable this on the epoll branch: Xapi_stdext_unix.Unixext.test_open 1024 *)
-  ()
+  Xapi_stdext_unix.Unixext.test_open 1024

From 9208739bcc40db3ad9d8b6e6032d36393a59ad1d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Mon, 22 Jul 2024 13:14:46 +0100
Subject: [PATCH 13/13] CP-32622: Thread.wait_timed_read/wait_timed_write
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 .../lib/xapi-stdext-threads/threadext.ml      | 20 +++++++++++++++++++
 .../lib/xapi-stdext-threads/threadext.mli     |  4 ++++
 2 files changed, 24 insertions(+)

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