From 8cfb5b4981a30e4fa0c5036a9bbdd0583f65cc2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Dec 2023 17:09:37 +0000 Subject: [PATCH] CP-47001: [xapi-fdcaps]: add operations module and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/xapi-fdcaps/operations.ml | 206 +++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 210 +++++++++++++++++++ lib/xapi-fdcaps/test/dune | 2 +- lib/xapi-fdcaps/test/test_operations.ml | 262 ++++++++++++++++++++++++ 4 files changed, 679 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-fdcaps/operations.ml create mode 100644 lib/xapi-fdcaps/operations.mli create mode 100644 lib/xapi-fdcaps/test/test_operations.ml diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml new file mode 100644 index 00000000..4b1580ab --- /dev/null +++ b/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 diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli new file mode 100644 index 00000000..9163adb6 --- /dev/null +++ b/lib/xapi-fdcaps/operations.mli @@ -0,0 +1,210 @@ +(* + * 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. + *) + +(** Statically enforce file descriptor capabilities using type parameters. + + *) + +open Properties + +(** a file descriptor with properties + Upper bounds are avoided here so that this type can be used in functors + *) +type +!'a props constraint 'a = (_, _) Properties.props + +(** like {!type:props} but with upper bounds on properties *) +type +!'a t = 'a props constraint 'a = (_, _) Properties.t + +(** convenience type for declaring properties *) +type (+!'a, +!'b) make = ('a, 'b) Properties.t t + +val pp : _ t Fmt.t +(** [pp formatter t] pretty prints [t] on [formatter]. *) + +val dump : _ t Fmt.t +(** [dump formatter t] prints a debug representation of [t] on [formatter]. *) + +val close : _ t -> unit +(** [close t] closes t. Doesn't raise an exception if it is already closed. + Other errors from the underlying {!val:Unix.close} are propagated. + *) + +val with_fd : 'a t -> ('a t -> 'b) -> 'b +(** [with_fd t f] calls [f t] and always closes [t] after [f] finishes. + [f] can also close [t] earlier if it wants to without a double close error. +*) + +val with_fd2 : 'a t * 'b t -> ('a t * 'b t -> 'c) -> 'c +(** [with_fd2 fd1 fd2 f] calls [f fd1 fd2] and always closes [t] after [f] finishes. *) + +module Syntax : sig + val ( let@ ) : ('a -> 'b) -> 'a -> 'b + (** [let@ fd = with_fd t in ... use fd] *) +end + +val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make +(** [pipe ()] creates an unnamed pipe. + @see {!val:Unix.pipe} + *) + +val socketpair : + Unix.socket_domain + -> Unix.socket_type + -> int + -> ([> rdwr], [> sock]) make * ([> rdwr], [> sock]) make +(** [socketpair domain type protocol] creates a socket pair. + @see {!val:Unix.socketpair} + *) + +val openfile_ro : 'a -> string -> Unix.open_flag list -> ([> rdonly], 'a) make +(** [openfile_ro kind path flags] opens an existing [path] readonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_rw : + ?custom_ftruncate:(int64 -> unit) + -> 'a + -> string + -> Unix.open_flag list + -> ([> rdwr], 'a) make +(** [openfile_rw kind path flags] opens an existing [path] readwrite. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_wo : 'a -> string -> Unix.open_flag list -> ([> wronly], 'a) make +(** [openfile_wo kind path flags] opens an existing [path] writeonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val creat : string -> Unix.open_flag list -> int -> ([> rdwr], [> reg]) make +(** [creat path flags perms] creates [path] readwrite. The path must not already exist. + + @param perms initial permissions for [path] + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val dev_null_out : unit -> ([> wronly], [> chr]) make +(** [dev_null_out ()] is "/dev/null" opened for writing *) + +val dev_null_in : unit -> ([> rdonly], [> chr]) make +(** [dev_null_in ()] is "/dev/null" opened for reading *) + +val dev_zero : unit -> ([> rdonly], [> chr]) make +(** [dev_zero ()] is "/dev/zero" opened for reading *) + +val shutdown_recv : ([< readable], [< sock]) make -> unit +(** [shutdown_recv t] shuts down receiving on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_send : ([< writable], [< sock]) make -> unit +(** [shutdown_send t] shuts down sending on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_all : ([< rdwr], [< sock]) make -> unit +(** [shutdown_all t] shuts down both receiving and sending on [t]. + + @see {!Unix.shutdown} + *) + +val ftruncate : ([< writable], [< truncatable]) make -> int64 -> unit +(** [ftruncate t size] sets the size of the regular file [t] to [size]. + + @see {!Unix.ftruncate} + *) + +val lseek : (_, [< seekable]) make -> int64 -> Unix.seek_command -> int64 +(** [lseek t off whence] sets the position of [t] to [off] with origin specified by [whence]. + + @see {!Unix.lseek} +*) + +val read : ([< readable], _) make -> bytes -> int -> int -> int +(** [read t buf off len] + @see {!Unix.read} + *) + +val single_write_substring : + ([< writable], _) make -> string -> int -> int -> int +(** [single_write_substring t buf off len] + + @see {!Unix.single_write_substring} +*) + +val set_nonblock : (_, [< espipe]) make -> unit +(** [set_nonblock t]. + + Only pipes, FIFOs and sockets are guaranteed to not block when this flag is set. + Although it is possible to set regular files and block devices as non-blocking, they currently still block + (although according to the manpage this may change in the future) + + @see {!Unix.set_nonblock} + *) + +val clear_nonblock : _ t -> unit +(** [clear_nonblock t]. + + We do not restrict clearing the non-blocking flag: that is just reverting back to default behaviour. + + @see {!Unix.clear_nonblock} + *) + +val with_tempfile : + ?size:int64 -> unit -> (string * ([> wronly], [> reg]) make -> 'a) -> 'a +(** [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 + -> ?delay_read_ms:float + -> ?delay_write_ms:float + -> string + -> (string * ([> rdwr], [> blk]) make -> 'a) + -> 'a +(** [with_temp_blk ?sector_size ?delay_read ?delay_write 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]. + + Deletes the block device when [f] finishes. + Only works when run as root. + + @param sector_size between 512 and 4096 + @param delay_read_ms delays read operations by specified milliseconds + @param delay_write_ms delays write operations by specified milliseconds +*) + +val setup : unit -> unit +(** [setup ()] installs a SIGPIPE handler *) + +(**/**) + +module For_test : sig + val unsafe_fd_exn : _ t -> Unix.file_descr +end diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index dd16b6aa..b8d21788 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,6 +1,6 @@ (tests (package xapi-fdcaps) - (names test_safefd test_properties) + (names test_safefd test_properties test_operations) (libraries xapi_fdcaps alcotest fmt) ) diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml new file mode 100644 index 00000000..f3c22f36 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -0,0 +1,262 @@ +(* + * 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 Xapi_fdcaps +open Properties +open Operations +open Syntax + +let b = Bytes.make 256 'x' + +let read_fd fd = + let (_ : int) = read fd b 0 (Bytes.length b) in + () + +let check_unsafe_raises ?(exn = Unix.EBADF) name t op = + (* if we bypass the type safety then we should get an error at runtime, + but only when the capability is 'no', not when it is 'removed' + *) + let fd = For_test.unsafe_fd_exn t in + let msg = Printf.sprintf "%s when <%s: no; ..>" name name in + let exn = Unix.Unix_error (exn, name, "") in + Alcotest.check_raises msg exn @@ fun () -> op fd + +let error_read_fd (t : ([< wronly], _) make) = + let@ fd = check_unsafe_raises "read" t in + let (_ : int) = Unix.read fd b 0 (Bytes.length b) in + () + +let str = "test" + +let write_fd fd = + let (_ : int) = single_write_substring fd str 0 (String.length str) in + () + +let error_write_fd (t : ([< rdonly], _) make) = + let@ fd = check_unsafe_raises "single_write" t in + let (_ : int) = Unix.single_write_substring fd str 0 (String.length str) in + () + +let test_ro fd = read_fd fd ; error_write_fd fd + +let test_wo fd = write_fd fd ; error_read_fd fd + +let test_lseek t = + let actual = lseek t 0L Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"starting position" ~expected:0L ~actual ; + let expected = 17L in + let actual = lseek t expected Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"jump1 position" ~expected ~actual ; + let actual = lseek t 3L Unix.SEEK_CUR in + Alcotest.(check' int64) ~msg:"jump2 position" ~expected:20L ~actual + +let error_lseek (t : (_, [< espipe]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ESPIPE "lseek" t in + let (_ : int) = Unix.lseek fd 0 Unix.SEEK_CUR in + () + +let test_ftruncate t = + let expected = 4000L in + ftruncate t expected ; + let actual = lseek t 0L Unix.SEEK_END in + Alcotest.(check' int64) ~msg:"size after ftruncate" ~expected ~actual + +type not_truncate = [blk | chr | dir | lnk | fifo | sock] + +let error_ftruncate (t : (_, [< not_truncate]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.EINVAL "ftruncate" t in + Unix.LargeFile.ftruncate fd 4000L + +type not_sock = [reg | blk | chr | dir | lnk | fifo] + +let error_shutdown (t : (_, [< not_sock]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ENOTSOCK "shutdown" t in + Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + +let test_fd2 make ops = + ops + |> List.map @@ fun (name, op1, op2) -> + let test () = + let@ fd1, fd2 = with_fd2 @@ make () in + pp Fmt.stdout fd1 ; + dump Fmt.stdout fd1 ; + (* the 2 operations may depend on each-other, e.g. write and read on a pipe, so must be part of same testcase *) + set_nonblock fd1 ; + set_nonblock fd2 ; + op2 fd2 ; + op1 fd1 ; + clear_nonblock fd1 ; + clear_nonblock fd2 + in + Alcotest.(test_case name `Quick) test + +let test_fd with_make ops = + ops + |> List.map @@ fun (name, op) -> + let test () = + let@ fd = with_make () in + op fd + in + Alcotest.(test_case name `Quick) test + +let test_pipe = + test_fd2 pipe + [ + ("wo,ro", test_ro, test_wo) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ; ("error_shutdown", error_shutdown, error_shutdown) + ] + +let test_sock = + let make () = socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + test_fd2 make + [ + ("read,write", read_fd, write_fd) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ] + +let with_fd fd f = pp Fmt.stdout fd ; dump Fmt.stdout fd ; with_fd fd f + +let with_tempfile () f = + let@ name, fd = with_tempfile () in + Fmt.pf Fmt.stdout "%s: %a@." name pp fd ; + f (name, fd) + +let test_single make f () = + let@ t = with_fd @@ make () in + error_shutdown t ; f t + +let test_safe_close () = + let@ t = with_fd @@ dev_null_in () in + close t ; close t + +let test_regular = + let with_make () f = + let@ _name, out = with_tempfile () in + f out + in + test_fd with_make + [ + ("wo", test_wo) + ; ("lseek", test_lseek) + ; ("ftruncate", test_ftruncate) + ; ("error_shutdown", error_shutdown) + ] + +let test_sock_shutdown_r () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + shutdown_recv fd1 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown of other end" exn in + write_fd fd2 + +let test_sock_shutdown_w () = + let@ _fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_send fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + +let test_sock_shutdown_all () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_all fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let () = + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd1 + +let test_block sector_size = + 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 + f fd + with Failure _ -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Failure "with_temp_blk") bt + in + if Unix.geteuid () = 0 then + run () + else + Alcotest.check_raises "non-root fails to create blockdevice" + (Failure "with_temp_blk") run + in + 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 ; + let@ fd1 = with_fd @@ creat name [] 0o600 in + pp Fmt.stdout fd1 ; + read_fd fd1 ; + write_fd fd1 ; + let@ fd2 = with_fd @@ openfile_rw `reg name [] in + pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 + +let tests = + Alcotest. + [ + test_case "/dev/null in" `Quick @@ test_single dev_null_in test_ro + ; test_case "/dev/null out" `Quick @@ test_single dev_null_out test_wo + ; test_case "/dev/zero" `Quick @@ test_single dev_zero test_ro + ; test_case "safe close" `Quick test_safe_close + ; test_case "socket shutdown read" `Quick test_sock_shutdown_r + ; test_case "socket shutdown write" `Quick test_sock_shutdown_w + ; test_case "socket shutdown both" `Quick test_sock_shutdown_all + ; test_case "create" `Quick test_creat + ] + +(* this must be the last test *) +let test_no_leaks () = + Gc.full_major () ; + Alcotest.(check' int) + ~msg:"Check for no FD leaks" ~expected:0 ~actual:(Safefd.leaked ()) + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("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) + ; ("xapi_fdcaps", tests) + ; ("no fd leaks", [Alcotest.test_case "no leaks" `Quick test_no_leaks]) + ]