CP-47001 Introduce file descriptor testing framework

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