CP-47001 Introduce file descriptor testing framework

.github/workflows/ocaml-ci.yml

@@ -9,7 +9,7 @@ jobs:
     name: Ocaml tests
     runs-on: ubuntu-20.04
     env:
-      package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck"
+      package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-fdcaps xapi-fd-test"
 
     steps:
       - name: Checkout code

.gitignore

@@ -1,3 +1,4 @@
 _build/
+_coverage/
 *.install
 .merlin

Makefile

@@ -1,10 +1,15 @@
 PROFILE=release
 
-.PHONY: build install uninstall clean test doc format
+.PHONY: build install uninstall clean test doc format coverage
 
 build:
 	dune build @install --profile=$(PROFILE)
 
+coverage:
+	dune runtest --instrument-with bisect_ppx --force
+	bisect-ppx-report html
+	bisect-ppx-report summary --per-file
+
 install:
 	dune install
 

dune-project

@@ -2,6 +2,8 @@
 (formatting (enabled_for ocaml))
 (name xapi-stdext)
 
+(cram enable)
+(implicit_transitive_deps false)
 (generate_opam_files true)
 
 (source (github xapi-project/stdext))
@@ -21,6 +23,8 @@
     (xapi-stdext-threads (= :version))
     (xapi-stdext-unix (= :version))
     (xapi-stdext-zerocheck (= :version))
+    (xapi-fdcaps (= :version))
+    (xapi-fdcaps-test (and (= :version) :with-test))
   )
 )
 
@@ -104,3 +108,27 @@
     (odoc :with-doc)
   )
 )
+
+(package
+  (name xapi-fdcaps)
+  (synopsis "Static capabilities for file descriptor operations")
+  (depends
+    (alcotest :with-test)
+    base-unix
+    fmt
+    (bisect_ppx :build)
+  )
+)
+
+(package
+  (name xapi-fd-test)
+  (synopsis "Test framework for file descriptor operations")
+  (depends
+    (alcotest :with-test)
+    base-unix
+    fmt
+    (mtime (>= 2.0.0))
+    logs
+    (qcheck-core (>= 0.21.2))
+  )
+)

lib/xapi-fd-test/dune

@@ -0,0 +1,6 @@
+; This will be used to test stdext itself, so do not depend on stdext here
+(library
+	(public_name xapi-fd-test)
+	(name xapi_fd_test)
+	(libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os)
+)

lib/xapi-fd-test/test/dune

@@ -0,0 +1,6 @@
+; This is a test framework, but we still need to test it
+(test
+	(package xapi-fd-test)
+	(name test_xapi_fd_test)
+	(libraries xapi_fd_test alcotest)
+)

lib/xapi-fdcaps/dune

@@ -0,0 +1,11 @@
+; Keep dependencies minimal here, ideally just OCaml stdlib
+; This will be used to test other functions in stdext, so it should not itself rely on other stdext libs!
+(library
+	(public_name xapi-fdcaps)
+	(name xapi_fdcaps)
+	(libraries fmt unix threads.posix)
+	(flags (:standard -principal))
+
+	; off by default, enable with --instrument-with bisect_ppx
+	(instrumentation (backend bisect_ppx))
+)

lib/xapi-fdcaps/operations.ml

@@ -0,0 +1,206 @@
+(*
+ * Copyright (C) 2023 Cloud Software Group
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Properties
+
+type +!'a props = {
+    props: ('b, 'c) Properties.props
+  ; custom_ftruncate: (int64 -> unit) option
+  ; fd: Safefd.t
+}
+  constraint 'a = ('b, 'c) Properties.props
+
+type +!'a t = 'a props constraint 'a = (_, _) Properties.t
+
+type (+!'a, +!'b) make = ('a, 'b) Properties.t t
+
+let dump ppf =
+  Fmt.(
+    Dump.(
+      record
+        [
+          field "props" (fun t -> t.props) pp
+        ; field "custom_ftruncate"
+            (fun t -> Option.is_some t.custom_ftruncate)
+            bool
+        ; field "fd" (fun t -> t.fd) Safefd.dump
+        ]
+    )
+  )
+    ppf
+
+let pp ppf =
+  Fmt.(
+    record
+      ~sep:Fmt.(any "; ")
+      [
+        field "props" (fun t -> t.props) pp
+      ; field "custom_ftruncate"
+          (fun t -> Option.is_some t.custom_ftruncate)
+          bool
+      ; field "fd" (fun t -> t.fd) Safefd.pp
+      ]
+  )
+    ppf
+
+let close t = Safefd.idempotent_close_exn t.fd
+
+let with_fd t f =
+  let finally () = close t in
+  Fun.protect ~finally (fun () -> f t)
+
+module Syntax = struct let ( let@ ) f x = f x end
+
+open Syntax
+
+let with_fd2 (fd1, fd2) f =
+  let@ fd1 = with_fd fd1 in
+  let@ fd2 = with_fd fd2 in
+  f (fd1, fd2)
+
+let make ?custom_ftruncate props fd : 'a t =
+  {fd= Safefd.of_file_descr fd; props; custom_ftruncate}
+
+let make_ro_exn kind fd = make (Properties.make `rdonly kind) fd
+
+let make_wo_exn kind fd = make (Properties.make `wronly kind) fd
+
+let make_rw_exn ?custom_ftruncate kind fd =
+  make (Properties.make `rdwr kind) ?custom_ftruncate fd
+
+let pipe () =
+  let kind = `fifo in
+  let ro, wo = Unix.pipe ~cloexec:true () in
+  (make_ro_exn kind ro, make_wo_exn kind wo)
+
+let socketpair domain typ proto =
+  let kind = `sock in
+  let fd1, fd2 = Unix.socketpair ~cloexec:true domain typ proto in
+  (make_rw_exn kind fd1, make_rw_exn kind fd2)
+
+let openfile_ro kind path flags =
+  make_ro_exn kind
+  @@ Unix.openfile path (Unix.O_RDONLY :: Unix.O_CLOEXEC :: flags) 0
+
+let openfile_rw ?custom_ftruncate kind path flags =
+  make_rw_exn ?custom_ftruncate kind
+  @@ Unix.openfile path (Unix.O_RDWR :: Unix.O_CLOEXEC :: flags) 0
+
+let openfile_wo kind path flags =
+  make_wo_exn kind
+  @@ Unix.openfile path (Unix.O_WRONLY :: Unix.O_CLOEXEC :: flags) 0
+
+let creat path flags perm =
+  make_rw_exn `reg
+  @@ Unix.openfile path
+       (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags)
+       perm
+
+let dev_null_out () = openfile_wo `chr "/dev/null" []
+
+let dev_null_in () = openfile_ro `chr "/dev/null" []
+
+let dev_zero () = openfile_ro `chr "/dev/zero" []
+
+let shutdown_recv t =
+  Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_RECEIVE
+
+let shutdown_send t =
+  Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND
+
+let shutdown_all t =
+  Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL
+
+let ftruncate t size =
+  match t.custom_ftruncate with
+  | None ->
+      Unix.LargeFile.ftruncate (Safefd.unsafe_to_file_descr_exn t.fd) size
+  | Some f ->
+      f size
+
+let lseek t off whence =
+  Unix.LargeFile.lseek (Safefd.unsafe_to_file_descr_exn t.fd) off whence
+
+let read t buf off len =
+  Unix.read (Safefd.unsafe_to_file_descr_exn t.fd) buf off len
+
+let single_write_substring t buf off len =
+  Unix.single_write_substring (Safefd.unsafe_to_file_descr_exn t.fd) buf off len
+
+let set_nonblock t = Unix.set_nonblock (Safefd.unsafe_to_file_descr_exn t.fd)
+
+let clear_nonblock t = Unix.clear_nonblock (Safefd.unsafe_to_file_descr_exn t.fd)
+
+let with_tempfile ?size () f =
+  let name, ch =
+    Filename.open_temp_file ~mode:[Open_binary] "xapi_fdcaps" "tmp"
+  in
+  let finally () =
+    close_out_noerr ch ;
+    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 = with_fd t in
+  size |> Option.iter (fun size -> ftruncate t size) ;
+  f (name, t)
+
+let check_output cmd args =
+  let cmd = Filename.quote_command cmd args in
+  let ch = Unix.open_process_in cmd in
+  let finally () =
+    try
+      let (_ : Unix.process_status) = Unix.close_process_in ch in
+      ()
+    with _ -> ()
+  in
+  Fun.protect ~finally @@ fun () ->
+  let out = In_channel.input_all ch |> String.trim in
+  match Unix.close_process_in ch with
+  | Unix.WEXITED 0 ->
+      out
+  | _ ->
+      failwith (Printf.sprintf "%s exited nonzero" cmd)
+
+let with_temp_blk ?(sector_size = 512) ?delay_read_ms:_ ?delay_write_ms:_ name f
+    =
+  let blkdev =
+    check_output "losetup"
+      [
+        "--show"
+      ; "--sector-size"
+      ; string_of_int sector_size
+      ; "--direct-io=on"
+      ; "--find"
+      ; name
+      ]
+  in
+  let custom_ftruncate size =
+    Unix.LargeFile.truncate name size ;
+    let (_ : string) = check_output "losetup" ["--set-capacity"; name] in
+    ()
+  in
+  let finally () =
+    let (_ : string) = check_output "losetup" ["--detach"; blkdev] in
+    ()
+  in
+  let@ () = Fun.protect ~finally in
+  let@ t = with_fd @@ openfile_rw ~custom_ftruncate `blk blkdev [] in
+  f (blkdev, t)
+
+let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
+
+module For_test = struct
+  let unsafe_fd_exn t = Safefd.unsafe_to_file_descr_exn t.fd
+end