CP-47001: [xapi-fdcaps]: add operations module and tests

Use the capabilities module to wrap most Unix operations needed in testing Unixext

Add a testsuite that checks that whenever the type says "never" the underlying file descriptor operation
would indeed raise an exception. This ensures that the type constraints we declare are actually correct.
The checks use unsafe operations that bypass the type layer.

Similarly check that operations that are accepted by the type system and marked as "always" in the type succeed.

Signed-off-by: Edwin Török <[email protected]>

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