From 956f52d7b60a0d81959e3137f33bb474f201dd5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 14:27:24 +0000 Subject: [PATCH 01/15] [maintenance]: disable implicit transitive deps MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Helps catch missing dependencies in dune files. Signed-off-by: Edwin Török --- dune-project | 1 + 1 file changed, 1 insertion(+) diff --git a/dune-project b/dune-project index a4973b11..cd983f13 100644 --- a/dune-project +++ b/dune-project @@ -2,6 +2,7 @@ (formatting (enabled_for ocaml)) (name xapi-stdext) +(implicit_transitive_deps false) (generate_opam_files true) (source (github xapi-project/stdext)) From b0f9bae0e3280723c163f5735ee9ca322f3f74d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 13:18:43 +0000 Subject: [PATCH 02/15] CP-47001: [xapi-fdcaps]: dune plumbing for new library MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be a new library that will provide a more type-safe interface to file descriptor operations. Useful on its own, but also for testing stdext. Minimal dependencies, only Unix (and Alcotest for testing). Signed-off-by: Edwin Török --- dune-project | 10 ++++++++ lib/xapi-fdcaps/dune | 7 ++++++ lib/xapi-fdcaps/test/dune | 5 ++++ lib/xapi-fdcaps/test/test_xapi_fdcaps.ml | 0 xapi-fdcaps.opam | 30 ++++++++++++++++++++++++ 5 files changed, 52 insertions(+) create mode 100644 lib/xapi-fdcaps/dune create mode 100644 lib/xapi-fdcaps/test/dune create mode 100644 lib/xapi-fdcaps/test/test_xapi_fdcaps.ml create mode 100644 xapi-fdcaps.opam diff --git a/dune-project b/dune-project index cd983f13..e4ed9cfb 100644 --- a/dune-project +++ b/dune-project @@ -105,3 +105,13 @@ (odoc :with-doc) ) ) + +(package + (name xapi-fdcaps) + (synopsis "Static capabilities for file descriptor operations") + (depends + (alcotest :with-test) + base-unix + fmt + ) +) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune new file mode 100644 index 00000000..1b0f0734 --- /dev/null +++ b/lib/xapi-fdcaps/dune @@ -0,0 +1,7 @@ +; 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 unix) +) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune new file mode 100644 index 00000000..8f304ecc --- /dev/null +++ b/lib/xapi-fdcaps/test/dune @@ -0,0 +1,5 @@ +(test + (package xapi-fdcaps) + (name test_xapi_fdcaps) + (libraries xapi_fdcaps alcotest) +) diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml b/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml new file mode 100644 index 00000000..e69de29b diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam new file mode 100644 index 00000000..9869d31c --- /dev/null +++ b/xapi-fdcaps.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Static capabilities for file descriptor operations" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" +depends: [ + "dune" {>= "2.7"} + "alcotest" {with-test} + "base-unix" + "fmt" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" From 96ab3f49107461772f4d6addb97a2b2de42acec0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 13:24:18 +0000 Subject: [PATCH 03/15] CP-47001: [xapi-fd-test]: dune plumbing for a new test framework MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be a test framework providing QCheck generators and properties for testing file descriptor operations. It will try to generate: * different kinds of file descriptors * actual data written/read on the other end of pipes and socket pairs * different speeds and delays on the other end to find buffering bugs * file descriptors that are >1024 to find bugs with select Signed-off-by: Edwin Török --- .github/workflows/ocaml-ci.yml | 2 +- dune-project | 15 ++ lib/xapi-fd-test/dune | 6 + lib/xapi-fd-test/test/dune | 6 + .../test/test_xapi_fd_test.ml} | 0 lib/xapi-fdcaps/dune | 2 +- lib/xapi-fdcaps/safefd.ml | 185 ++++++++++++++++++ lib/xapi-fdcaps/safefd.mli | 115 +++++++++++ lib/xapi-fdcaps/test/dune | 6 +- lib/xapi-fdcaps/test/test_safefd.ml | 123 ++++++++++++ xapi-fd-test.opam | 33 ++++ xapi-stdext.opam | 2 + 12 files changed, 490 insertions(+), 5 deletions(-) create mode 100644 lib/xapi-fd-test/dune create mode 100644 lib/xapi-fd-test/test/dune rename lib/{xapi-fdcaps/test/test_xapi_fdcaps.ml => xapi-fd-test/test/test_xapi_fd_test.ml} (100%) create mode 100644 lib/xapi-fdcaps/safefd.ml create mode 100644 lib/xapi-fdcaps/safefd.mli create mode 100644 lib/xapi-fdcaps/test/test_safefd.ml create mode 100644 xapi-fd-test.opam diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml index bb212541..3758c01d 100644 --- a/.github/workflows/ocaml-ci.yml +++ b/.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 diff --git a/dune-project b/dune-project index e4ed9cfb..ff2bd62a 100644 --- a/dune-project +++ b/dune-project @@ -22,6 +22,8 @@ (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) (xapi-stdext-zerocheck (= :version)) + (xapi-fdcaps (= :version)) + (xapi-fdcaps-test (and (= :version) :with-test)) ) ) @@ -115,3 +117,16 @@ fmt ) ) + +(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)) + ) +) diff --git a/lib/xapi-fd-test/dune b/lib/xapi-fd-test/dune new file mode 100644 index 00000000..b2a0d2fe --- /dev/null +++ b/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) +) diff --git a/lib/xapi-fd-test/test/dune b/lib/xapi-fd-test/test/dune new file mode 100644 index 00000000..10b800a0 --- /dev/null +++ b/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) +) diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml b/lib/xapi-fd-test/test/test_xapi_fd_test.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_xapi_fdcaps.ml rename to lib/xapi-fd-test/test/test_xapi_fd_test.ml diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 1b0f0734..6daf1416 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -3,5 +3,5 @@ (library (public_name xapi-fdcaps) (name xapi_fdcaps) - (libraries unix) + (libraries fmt unix) ) diff --git a/lib/xapi-fdcaps/safefd.ml b/lib/xapi-fdcaps/safefd.ml new file mode 100644 index 00000000..6290cd55 --- /dev/null +++ b/lib/xapi-fdcaps/safefd.ml @@ -0,0 +1,185 @@ +(* + * 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. + *) + +let string_of_file_kind = + let open Unix in + function + | S_REG -> + "regular file" + | S_BLK -> + "block device" + | S_CHR -> + "character device" + | S_DIR -> + "directory" + | S_LNK -> + "symlink" + | S_FIFO -> + "FIFO/pipe" + | S_SOCK -> + "socket" + +let pp_kind = Fmt.of_to_string string_of_file_kind + +module Identity = struct + type t = { + kind: Unix.file_kind + ; device: int + ; inode: int (* should be int64? *) + } + + let of_fd fd = + let open Unix.LargeFile in + let stat = fstat fd in + {kind= stat.st_kind; device= stat.st_dev; inode= stat.st_ino} + + let same a b = a.kind = b.kind && a.device = b.device && a.inode = b.inode + + let pp = + Fmt.( + record + ~sep:Fmt.(any ", ") + [ + field "kind" (fun t -> t.kind) pp_kind + ; field "device" (fun t -> t.device) int + ; field "inode" (fun t -> t.inode) int + ] + ) +end + +type t = { + fd: (Unix.file_descr, Printexc.raw_backtrace) result Atomic.t + ; opened_at: Printexc.raw_backtrace + ; original: Identity.t +} + +let pp ppf t = + (* print only essential info that fits on a single line *) + Fmt.pf ppf "@[FD %a: %a@]" + (Fmt.result ~ok:Fmt.(any "open") ~error:Fmt.(any "closed")) + (Atomic.get t.fd) Identity.pp t.original + +let pp_closed ppf bt = + let exception Closed_at in + Fmt.exn_backtrace ppf (Closed_at, bt) + +let pp_opened_at ppf bt = + let exception Opened_at in + Fmt.exn_backtrace ppf (Opened_at, bt) + +let dump = + Fmt.( + Dump.( + record + [ + field "fd" + (fun t -> Atomic.get t.fd) + Fmt.Dump.(result ~ok:(any "opened") ~error:pp_closed) + ; field "opened_at" (fun t -> t.opened_at) pp_opened_at + ; field "original" (fun t -> t.original) Identity.pp + ] + ) + ) + +let location () = + (* We could raise and immediately catch an exception but that will have a very short stacktrace, + [get_callstack] is better. + *) + Printexc.get_callstack 1000 + +let nop = + { + fd= Atomic.make (Error (location ())) + ; opened_at= Printexc.get_callstack 0 + ; original= Identity.of_fd Unix.stdin + } + +let check_exn ~caller t fd = + let actual = Identity.of_fd fd in + if not (Identity.same t.original actual) then ( + let msg = + Format.asprintf "@[File descriptor mismatch: %a != %a@]" Identity.pp + t.original Identity.pp actual + in + (* invalidate FD so nothing else uses it anymore, we know it points to elsewhere now *) + Atomic.set t.fd (Error (location ())) ; + (* raise backtrace with original open location *) + Printexc.raise_with_backtrace + Unix.(Unix_error (EBADF, caller, msg)) + t.opened_at + ) + +let close_common_exn t = + let closed = Error (location ()) in + (* ensure noone else can access it, before we close it *) + match Atomic.exchange t.fd closed with + | Error _ as e -> + (* put back the original backtrace *) + Atomic.set t.fd e ; e + | Ok fd -> + check_exn ~caller:"close_common_exn" t fd ; + Ok (Unix.close fd) + +let close_exn t = + match close_common_exn t with + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + (* raise with previous close's backtrace *) + Printexc.raise_with_backtrace ebadf bt + | Ok () -> + () + +let idempotent_close_exn t = + let (_ : _ result) = close_common_exn t in + () + +let leak_count = Atomic.make 0 + +let leaked () = Atomic.get leak_count + +let finalise t = + match Atomic.get t.fd with + | Ok _ -> + Atomic.incr leak_count ; + if Sys.runtime_warnings_enabled () then + Format.eprintf "@.Warning: leaked file descriptor detected:@,%a@]@." + pp_opened_at t.opened_at + | Error _ -> + () + +let of_file_descr fd = + let v = + { + fd= Atomic.make (Ok fd) + ; opened_at= location () + ; original= Identity.of_fd fd + } + in + Gc.finalise finalise v ; v + +let unsafe_to_file_descr_exn t = + match Atomic.get t.fd with + | Ok fd -> + fd + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + Printexc.raise_with_backtrace ebadf bt + +let with_fd_exn t f = + let fd = unsafe_to_file_descr_exn t in + let r = f fd in + check_exn ~caller:"with_fd_exn" t fd ; + r + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore diff --git a/lib/xapi-fdcaps/safefd.mli b/lib/xapi-fdcaps/safefd.mli new file mode 100644 index 00000000..710d1a5e --- /dev/null +++ b/lib/xapi-fdcaps/safefd.mli @@ -0,0 +1,115 @@ +(* + * 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. + *) + +(** Safe wrapper around {!type:Unix.file_descr} that detects "use after close" errors + + {!type:Unix.file_descr} is just an integer and cannot track whether {!val:Unix.close} has been called. + File descriptor numbers are reused by newly open file descriptors, so using a file descriptor that is already closed + doesn't always result in a visible error, but is nevertheless a programming error that should be detected. + + E.g. the following sequence would write data to the wrong file ([fd2] instead of [fd1]), + and raise no errors at runtime: + {[ + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.close fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.write_substring fd1 "test" 0 4; + Unix.close fd2 + ]} + + This module introduces a lightweight wrapper around {!type:Unix.file_descr}, + and detects attempts to use a file descriptor after it has been closed: + {[ + open Xapi_fdcaps + + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.close_exn fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.with_fd_exn fd1 (fun fd -> Unix.write_substring fd "test" 0 4); + ]} + + It raises {!val:Unix.EBADF}: + {[ Exception: Unix.Unix_error(Unix.EBADF, "unsafe_to_file_descr_exn", "") ]} + + The callback of {!val:with_fd_exn} has access to the underlying {!type:Unix.file_descr}, + and may accidentally call {!val:Unix.close}. + + To detect that {!val:with_fd_exn} calls {!val:Unix.LargeFile.fstat} to check that the file descriptor + remained the "same" after the call. + File descriptors are considered to be the same if their kind, device and inode remain unchanged + (obviously other parts of the stat structure such as timestamps and size may change between calls). + This doesn't detect all bugs, but detects most common bugs + (hardlinked files will still show up as the same but the file position may have been different, which is not checked). + + The extra system calls have an overhead so an unsafe version is available, but not documented (it should only be used internally by other modules in {!mod:Xapi_fdcaps}). + + With the safe wrapper we also have a non-integer type that we can attach a finaliser too. + This is used to detect and close leaked file descriptors safely (by checking that it is "the same" that we originally opened). +*) + +(** a file descriptor that is safe against double close *) +type t + +val of_file_descr : Unix.file_descr -> t +(** [of_file_descr fd] wraps [fd]. + + *) + +val idempotent_close_exn : t -> unit +(** [idempotent_close_exn t] closes [t], and doesn't raise an exception if [t] is already closed. + Other exceptions may still escape (e.g. if the underlying [close] has reported an [ENOSPC] or [EIO] error). +*) + +val close_exn : t -> unit +(** [close_exn t] closes t and raises an exception if [t] is already closed. + + @raises Unix_error(Unix.EBADF,_,_) if [t] is already closed. +*) + +val with_fd_exn : t -> (Unix.file_descr -> 'a) -> 'a +(** [with_fd_exn t f] calls [f fd] with the underlying file descriptor. + [f] must not close [fd]. + + @raises Unix_error(Unix.EBADF,_,_) if the file descriptor is not the same after [f] terminates. +*) + +val nop : t +(** [nop] is a file descriptor that is always closed and no operations are valid on it. *) + +val pp_kind : Format.formatter -> Unix.file_kind -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +val pp : Format.formatter -> t -> unit +(** [pp formatter t] pretty prints information about [t] on [formatter]. *) + +val dump : Format.formatter -> t -> unit +(** [dump formatter t] prints all the debug information available about [t] on [formatter] *) + +(**/**) + +(* For small wrappers and high frequency calls like [read] and [write]. + Should only be used by the wrappers in {!mod:Operations}, hence hidden from the documentation. +*) + +val setup : unit -> unit +(** [setup ()] sets up a [SIGPIPE] handler. + With the handler set up a broken pipe will result in a [Unix.EPIPE] exception instead of killing the program *) + +val leaked : unit -> int +(** [leaked ()] is a count of leaked file descriptors detected. + Run [Gc.full_major ()] to get an accurate count before calling this *) + +(**/**) + +val unsafe_to_file_descr_exn : t -> Unix.file_descr diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index 8f304ecc..b20b3716 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,5 +1,5 @@ -(test +(tests (package xapi-fdcaps) - (name test_xapi_fdcaps) - (libraries xapi_fdcaps alcotest) + (names test_safefd) + (libraries xapi_fdcaps alcotest fmt) ) diff --git a/lib/xapi-fdcaps/test/test_safefd.ml b/lib/xapi-fdcaps/test/test_safefd.ml new file mode 100644 index 00000000..ea1b1343 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_safefd.ml @@ -0,0 +1,123 @@ +(* + * 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 Safefd + +let make_safefd () = + let rd, wr = Unix.pipe ~cloexec:true () in + (of_file_descr rd, of_file_descr wr) + +let test_safefd_regular () = + let rd, wr = Unix.pipe ~cloexec:true () in + let rd, wr = (of_file_descr rd, of_file_descr wr) in + let (_ : Unix.LargeFile.stats) = with_fd_exn rd Unix.LargeFile.fstat + and (_ : Unix.LargeFile.stats) = with_fd_exn wr Unix.LargeFile.fstat in + close_exn rd ; close_exn wr + +let test_safefd_double_close () = + let rd, wr = make_safefd () in + close_exn rd ; + close_exn wr ; + let exn = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "double close" exn (fun () -> close_exn wr) + +let test_safefd_idempotent_close () = + let rd, wr = make_safefd () in + close_exn rd ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr + +let test_safefd_unix_close () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "fstat", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr Unix.close + ) + +let remove_unix_error_arg f = + try f () + with Unix.Unix_error (code, fn, _) -> + (* remove arg, so we can match with [Alcotest.check_raises] *) + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Unix.Unix_error (code, fn, "")) bt + +let with_fd_exn f arg = remove_unix_error_arg (fun () -> with_fd_exn f arg) + +let close_reuse fd = + Unix.close fd ; + (* open and leak fd, this should reuse the FD number of [fd], but we should be able to detect via stat *) + let _, _ = Unix.pipe () in + () + +let test_safefd_unix_close_reuse () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "with_fd_exn", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr close_reuse + ) + +let leak () = + let rd, wr = make_safefd () in + close_exn rd ; + (* leak wr *) + unsafe_to_file_descr_exn wr + +let test_safefd_finalised () = + let _leaked_fd : Unix.file_descr = leak () in + Gc.full_major () ; + Alcotest.( + check' int ~msg:"leak detected" ~expected:2 ~actual:(Safefd.leaked ()) + ) + +let test_pp_and_dump () = + let a, b = make_safefd () in + Format.printf "a: %a@,b: %a@." Safefd.pp a Safefd.pp b ; + Format.printf "a: %a@,b: %a@." Safefd.dump a Safefd.dump b + +let test_nop () = + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "nop close raises" ebadf (fun () -> close_exn nop) + +let test_unsafe_closed () = + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + dump Fmt.stdout nop ; + Alcotest.check_raises "unsafe raises" ebadf (fun () -> + let (_ : Unix.file_descr) = unsafe_to_file_descr_exn nop in + () + ) + +let tests_safefd = + Alcotest. + [ + test_case "nop" `Quick test_nop + ; test_case "regular ops" `Quick test_safefd_regular + ; test_case "double close detected" `Quick test_safefd_double_close + ; test_case "idempotent close" `Quick test_safefd_idempotent_close + ; test_case "Unix.close detected" `Quick test_safefd_unix_close + ; test_case "Unix.close detected after reuse" `Quick + test_safefd_unix_close_reuse + ; test_case "FD leak detected" `Quick test_safefd_finalised + ; test_case "test pp and dump" `Quick test_pp_and_dump + ; test_case "unsafe of closed fd" `Quick test_unsafe_closed + ] + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" [("safefd", tests_safefd)] diff --git a/xapi-fd-test.opam b/xapi-fd-test.opam new file mode 100644 index 00000000..faaeee26 --- /dev/null +++ b/xapi-fd-test.opam @@ -0,0 +1,33 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Test framework for file descriptor operations" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" +depends: [ + "dune" {>= "2.7"} + "alcotest" {with-test} + "base-unix" + "fmt" + "mtime" {>= "2.0.0"} + "logs" + "qcheck-core" {>= "0.21.2"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext.opam b/xapi-stdext.opam index 40429802..04db4bb6 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -16,6 +16,8 @@ depends: [ "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} + "xapi-fdcaps" {= version} + "xapi-fdcaps-test" {= version & with-test} "odoc" {with-doc} ] build: [ From 2ca1c34d5175a1b279da4fee7e30fd26cdce5026 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 15 Dec 2023 17:24:16 +0000 Subject: [PATCH 04/15] CP-47001: [xapi-fdcaps]: add -principal flag MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We are going to use type-level constraints a lot. Try to future proof it by using the recommended compiler flag. `ocamlc` says this about `-principal`: > When using labelled arguments and/or polymorphic methods, this flag is required to > ensure future versions of the compiler will be able to infer types correctly, even if internal algorithms change Signed-off-by: Edwin Török --- lib/xapi-fdcaps/dune | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 6daf1416..0891178f 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -3,5 +3,6 @@ (library (public_name xapi-fdcaps) (name xapi_fdcaps) - (libraries fmt unix) + (libraries fmt unix threads.posix) + (flags (:standard -principal)) ) From 6a6a2ff73c921ce4b7193467ad236cc327ff8432 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 15 Dec 2023 17:26:16 +0000 Subject: [PATCH 05/15] CP-47001: [xapi-fdcaps]: optional coverage support MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is not enabled by default (but bisect-ppx is nevertheless a build-time dependency) Usage: `make coverage` Signed-off-by: Edwin Török --- .gitignore | 1 + Makefile | 7 ++++++- dune-project | 1 + lib/xapi-fdcaps/dune | 3 +++ xapi-fdcaps.opam | 1 + 5 files changed, 12 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 4e66100e..b67aaac8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ _build/ +_coverage/ *.install .merlin diff --git a/Makefile b/Makefile index 70ed716f..54a79af6 100644 --- a/Makefile +++ b/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 diff --git a/dune-project b/dune-project index ff2bd62a..b9d22266 100644 --- a/dune-project +++ b/dune-project @@ -115,6 +115,7 @@ (alcotest :with-test) base-unix fmt + (bisect_ppx :build) ) ) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 0891178f..cb3c54ea 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -5,4 +5,7 @@ (name xapi_fdcaps) (libraries fmt unix threads.posix) (flags (:standard -principal)) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) ) diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam index 9869d31c..fffa27cc 100644 --- a/xapi-fdcaps.opam +++ b/xapi-fdcaps.opam @@ -11,6 +11,7 @@ depends: [ "alcotest" {with-test} "base-unix" "fmt" + "bisect_ppx" {build} "odoc" {with-doc} ] build: [ From 872f5ede73c3d8de207a605a760c3f769c42a05b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Dec 2023 17:07:58 +0000 Subject: [PATCH 06/15] CP-47001: [xapi-fdcaps]: add properties module and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Lightweight wrapper using polymorphic variants to track read, write, and file kind properties on file descriptors. We only track the property at the time the file descriptor was opened. This prevents bugs like accidentally swapping the read and write ends of a pipe, or attempting to run an operation on a file descriptor that would alway s fail (e.g. setting a socket timeout on a pipe) Write tests using cram-style expect tests that the operations we expect to be forbidden by this type system are actually forbidden. The error messages may be compiler version dependent, so only run them on OCaml 4.14.1 for now. Signed-off-by: Edwin Török --- dune-project | 1 + lib/xapi-fdcaps/properties.ml | 123 +++++++++++++++ lib/xapi-fdcaps/properties.mli | 192 ++++++++++++++++++++++++ lib/xapi-fdcaps/test/dune | 7 +- lib/xapi-fdcaps/test/properties.t | 23 +++ lib/xapi-fdcaps/test/test_properties.ml | 94 ++++++++++++ 6 files changed, 439 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-fdcaps/properties.ml create mode 100644 lib/xapi-fdcaps/properties.mli create mode 100644 lib/xapi-fdcaps/test/properties.t create mode 100644 lib/xapi-fdcaps/test/test_properties.ml diff --git a/dune-project b/dune-project index b9d22266..d3b8f170 100644 --- a/dune-project +++ b/dune-project @@ -2,6 +2,7 @@ (formatting (enabled_for ocaml)) (name xapi-stdext) +(cram enable) (implicit_transitive_deps false) (generate_opam_files true) diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml new file mode 100644 index 00000000..1a60015f --- /dev/null +++ b/lib/xapi-fdcaps/properties.ml @@ -0,0 +1,123 @@ +(* + * 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. + *) + +type (+!'a, +!'b) props = {rw: 'a; kind: 'b} + +type rdonly = [`rdonly] + +type wronly = [`wronly] + +type rdwr = [`rdwr] + +let pp_rw fmt = + Fmt.of_to_string + (function #rdonly -> "RDONLY" | #wronly -> "WRONLY" | #rdwr -> "RDWR") + fmt + +type reg = [`reg] + +type blk = [`blk] + +type chr = [`chr] + +type dir = [`dir] + +type lnk = [`lnk] + +type fifo = [`fifo] + +type sock = [`sock] + +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +let to_unix_kind = + let open Unix in + function + | #reg -> + S_REG + | #blk -> + S_BLK + | #chr -> + S_CHR + | #dir -> + S_DIR + | #lnk -> + S_LNK + | #fifo -> + S_FIFO + | #sock -> + S_SOCK + +let pp_kind fmt = + Fmt.using to_unix_kind Safefd.pp_kind fmt + +let pp fmt = + Fmt.( + record + ~sep:Fmt.(any ", ") + [field "rw" (fun t -> t.rw) pp_rw; field "kind" (fun t -> t.kind) pp_kind] + ) + fmt + +type readable = [rdonly | rdwr] + +type writable = [wronly | rdwr] + +type rw = [rdonly | wronly | rdwr] + +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +let as_readable ({rw= #readable; _} as t) = t + +let as_writable ({rw= #writable; _} as t) = t + +let as_readable_opt = function + | {rw= #readable; _} as x -> + Some x + | {rw= #wronly; _} -> + None + +let as_writable_opt = function + | {rw= #writable; _} as x -> + Some x + | {rw= #rdonly; _} -> + None + +type espipe = [fifo | sock] + +let as_kind_opt expected ({kind; _} as t) = + (* we cannot compare the values directly because we want to keep the type parameters distinct *) + match (kind, expected) with + | #reg, #reg -> + Some {t with kind= expected} + | #blk, #blk -> + Some {t with kind= expected} + | #chr, #chr -> + Some {t with kind= expected} + | #dir, #dir -> + Some {t with kind= expected} + | #lnk, #lnk -> + Some {t with kind= expected} + | #fifo, #fifo -> + Some {t with kind= expected} + | #sock, #sock -> + Some {t with kind= expected} + | #kind, #kind -> + None + +type seekable = [reg | blk] + +type truncatable = reg + +let make rw kind = {rw; kind} diff --git a/lib/xapi-fdcaps/properties.mli b/lib/xapi-fdcaps/properties.mli new file mode 100644 index 00000000..0afc529c --- /dev/null +++ b/lib/xapi-fdcaps/properties.mli @@ -0,0 +1,192 @@ +(* + * 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. + *) + +(** Static file property checking + + When file descriptors are open they have: + * a file kind: ({!type:reg}, {!type:blk), {!type:chr}, {!type:lnk}, {!type:fifo}, {!type:sock}) + * an open mode: {!type:readonly}, {!type:writeonly}, {!type:readwrite} depending on the {!type:Unix.open_flag} used + + Depending on these properties there are {!val:Unix} operations on file descriptors that always fail, e.g.: + * writing to a read-only file + * socket operation on non-socket + * seeking on a pipe + * ... + + The read-write property can also change at runtime: + * {!val:Unix.shutdown} can be used to shutdown the socket in either direction + + We track the property of the file at open time, and we reject operations that we can statically determine to always fail. + This doesn't guarantee the absence of runtime errors, but catches programming errors like accidentally swapping the read and write ends of a pipe, + or attempting to set a socket timeout on a pipe. + + We use polymorphic variants as type parameters to track these properties: they are simple to use and work well with type inference. + They also allow dispatching at runtime on the actual capabilities available, although they could be purely compile-time types (phantom types). + + Alternative approaches (typically with phantom types): + * abstract types as phantom type parameters: don't work well with type inference, and cannot express removing a property + * behavioural types (recursive polymorphic variants) can express removing a property, but error messages and type signatures become too long + * object phantom types strike a good balance between clarity of error messages and complexity of type signatures + + It'd be also possible to use purely boolean properties (capabilities), but that causes a long type signature, and allows expressing meaningless combinations, + such as a file that is both a socket and seekable, which is impossible. + Instead we directly map the concepts from the Unix module to a polymorphic variant (e.g. instead of separate read and write properties we have the 3 properties from the Unix module). + +{b References.} +{ul + {- Yaron Minsky. + {e {{:https://blog.janestreet.com/howto-static-access-control-using-phantom-types/}HOWTO: Static access control using phantom types}. 2008.}} + {- KC Sivaramakrishnan. + {e {{:https://kcsrk.info/ocaml/types/2016/06/30/behavioural-types/#file-descriptors}Behavioural types}. 2016.}} + {- Florian Angeletti. + {e {{:https://stackoverflow.com/a/55081337}Object phantom types}. 2019.}} +} +*) + +(** {1 File properties} + + Polymorphic type parameters for the set of properties a file descriptor may have on a given codepath. + E.g. {[> rdonly | wronly]} means that this codepath may be reached by a file descriptor with either of these properties, + although of course a file descriptor can only have one of these properties at a time. + + Usual rules for using polymorphic variants apply: + * when receiving a type declare an upper bound on what the code can handle, e.g. : {[< readable]} + * when returning a type declare a lower bound to make type inference/unification work, e.g. : {[> readable]} + + Naming conventions: + * [type property ] + * [val as_property : [< property] t -> [> property] t] + * [val as_property_opt: [< all] t -> [> property] t option] +*) + +(** file properties: {!type:rw}, {!type:kind} + + Upper bounds are avoided here to make the type usable in functors + *) +type (+!'a, +!'b) props + +(** {2 Read/write property} + + A file can be read-only, write-only, or read-write. +*) + +(** file opened with {!val:Unix.O_RDONLY} or the read end of a pipe *) +type rdonly = [`rdonly] + +(** file opened with {!val:Unix.O_WRONLY} or the write end of a pipe *) +type wronly = [`wronly] + +(** file opened with {!val:Unix.O_RDWR} or a socketpair *) +type rdwr = [`rdwr] + +(** file opened with either {!val:Unix.O_RDONLY} or {!val:Unix.O_RDWR} *) +type readable = [rdonly | rdwr] + +(** file opened with either {!val:Unix.O_WRONLY} or {!val:Unix.O_RDWR} *) +type writable = [wronly | rdwr] + +(** the read-write property *) +type rw = [rdonly | wronly | rdwr] + +val pp_rw : Format.formatter -> [< rw] -> unit +(** [pp_rw formatter rw] pretty prints the [rw] state on [formatter]. *) + +(** {2 File kind} *) + +(** A regular file, {!val:Unix.S_REG} *) +type reg = [`reg] + +(** A block device, {!val:Unix.S_BLK} *) +type blk = [`blk] + +(** A character device, {!val:Unix.S_CHR} *) +type chr = [`chr] + +(** A directory, {!val:Unix.S_DIR} *) +type dir = [`dir] + +(** A symbolic link, {!val:Unix.S_LNK} *) +type lnk = [`lnk] + +(** A pipe or FIFO, {!val:Unix.S_FIFO} *) +type fifo = [`fifo] + +(** A socket, {!val:Unix.S_SOCK} *) +type sock = [`sock] + +(** a {!type:Unix.file_kind} *) +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +val pp_kind : Format.formatter -> [< kind] -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +(** {2 Property type} *) + +(** upper bounds on properties *) +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +(** {2 Operations on read-write properties} *) + +val as_readable : ([< readable], 'a) t -> ([> readable], 'a) t +(** [as_readable t] requires [t] to be readable and ignores the writeonly property. *) + +val as_writable : ([< writable], 'a) t -> ([> writable], 'a) t +(** [as_writable t] requires [t] to be writable and ignores the readonly property. *) + +val as_readable_opt : ([< rw], 'a) t -> ([> readable], 'a) t option +(** [as_readable_opt t] tests for the presence of the readable property at runtime. + + @returns [Some t] when [t] is readable, and [None] otherwise +*) + +val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option +(** [as_writable_opt t] tests for the presence of the writable property at runtime. + + @returns [Some t] when [t] is writable, and [None] otherwise +*) + +(** {2 Operations on file kind properties} *) + +val to_unix_kind : kind -> Unix.file_kind +(** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) + +(** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) +type espipe = [fifo | sock] + +val as_kind_opt : ([< kind] as 'a) -> ('b, [< kind]) t -> ('b, 'a) t option +(** [as_kind_opt kind t] checks whether [t] is of type [kind]. + + @returns [Some t] if [t] is of type [kind], and [None] otherwise + *) + +(** {2 Properties derived from file kind} *) + +(** seek may be implementation defined on devices other than regular files or block devices. + + E.g. {!type:chr} devices would always return 0 when seeking, which doesn't follow the usual semantics of seek. +*) +type seekable = [reg | blk] + +(** truncate only works on regular files *) +type truncatable = reg + +(** {2 Create properties} *) + +val make : ([< rw] as 'a) -> ([< kind] as 'b) -> ('a, 'b) t +(** [make rw kind] builds a file property *) + +(** {2 Pretty printing} *) + +val pp : Format.formatter -> (_, _) t -> unit +(** [pp formatter t] pretty prints the properties on [formatter]. *) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index b20b3716..dd16b6aa 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,5 +1,10 @@ (tests (package xapi-fdcaps) - (names test_safefd) + (names test_safefd test_properties) (libraries xapi_fdcaps alcotest fmt) ) + +(cram + (deps (package xapi-fdcaps)) + (enabled_if (= %{ocaml_version} 4.14.1)) +) diff --git a/lib/xapi-fdcaps/test/properties.t b/lib/xapi-fdcaps/test/properties.t new file mode 100644 index 00000000..52fcd066 --- /dev/null +++ b/lib/xapi-fdcaps/test/properties.t @@ -0,0 +1,23 @@ +Check that we get compile errors when trying to use a read-only or write-only property with the opposite operation: + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_readable (make `wronly `reg) in () + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml + File "t.ml", line 2, characters 40-42: + 2 | let _ = as_readable (make `wronly `reg) in () + ^^ + Error: Syntax error + [2] + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_writable (make `rdonly `reg) in () + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml + File "t.ml", line 2, characters 40-42: + 2 | let _ = as_writable (make `rdonly `reg) in () + ^^ + Error: Syntax error + [2] diff --git a/lib/xapi-fdcaps/test/test_properties.ml b/lib/xapi-fdcaps/test/test_properties.ml new file mode 100644 index 00000000..24484393 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_properties.ml @@ -0,0 +1,94 @@ +(* + * 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.Properties + +(* compilation tests, failed ones are in [properties.t] *) +let () = + let (_ : (_, _) t) = as_readable (make `rdonly `reg) in + let (_ : (_, _) t) = as_writable (make `wronly `reg) in + let (_ : (_, _) t) = as_readable (make `rdwr `reg) in + let (_ : (_, _) t) = as_writable (make `rdwr `reg) in + let #espipe = `fifo in + let #espipe = `sock in + let #seekable = `reg in + let #seekable = `blk in + let #truncatable = `reg in + () + +(* test that unification works *) +let any_file = function + | 0 -> + make `rdonly `reg + | 1 -> + make `rdonly `blk + | 2 -> + make `rdonly `chr + | 3 -> + make `rdonly `dir + | 4 -> + make `rdonly `sock + | _ -> + make `rdonly `fifo + +let all_rw = [`rdonly; `wronly; `rdwr] + +let test_as_rw_opt f expected_set = + let t = Alcotest.testable pp ( = ) in + all_rw + |> List.map @@ fun rw -> + let test () = + let prop = make rw `reg in + let expected = if List.mem rw expected_set then Some prop else None in + let msg = Fmt.str "as_%a_opt" pp_rw rw in + Alcotest.(check' @@ option t) ~msg ~expected ~actual:(f prop) + in + Alcotest.test_case (Fmt.to_to_string pp_rw rw) `Quick test + +let test_pp prop = Alcotest.test_case (Fmt.to_to_string pp prop) `Quick ignore + +let all_kinds = [`reg; `blk; `chr; `dir; `lnk; `sock; `fifo] + +let test_to_unix_kind () = + let all_unix_kinds = + List.sort_uniq compare @@ all_kinds |> List.map to_unix_kind + in + Alcotest.(check' int) + ~msg:"to_unix_kind mapping is unique" ~expected:(List.length all_kinds) + ~actual:(List.length all_unix_kinds) + +let test_as_kind = + let t = Alcotest.testable pp ( = ) in + all_kinds + |> List.map @@ fun k1 -> + ( Fmt.str "as_kind_opt %a" pp_kind k1 + , all_kinds + |> List.map @@ fun k2 -> + let test () = + let prop = make `rdonly k2 in + let actual = as_kind_opt k1 prop in + let expected = if k1 = k2 then Some prop else None in + Alcotest.(check' @@ option t) ~msg:"as_kind_opt" ~expected ~actual + in + Alcotest.test_case (Fmt.to_to_string pp_kind k2) `Quick test + ) + +let tests = + let open Alcotest in + ("to_unix_kind", [test_case "to_unix_kind" `Quick test_to_unix_kind]) + :: ("as_readable_opt", test_as_rw_opt as_readable_opt [`rdonly; `rdwr]) + :: ("as_writable_opt", test_as_rw_opt as_writable_opt [`wronly; `rdwr]) + :: test_as_kind + +let () = Alcotest.run ~show_errors:true "test_capabilities" tests 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 07/15] 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]) + ] From 270aea67305ec8d99270375a5fb9b20b4ae82c6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 11:00:03 +0000 Subject: [PATCH 08/15] CP-47001: [xapi-fdcaps] add sections to Operations documentation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.mli | 25 +++++++++++++++++++------ lib/xapi-fdcaps/properties.ml | 3 +-- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index 9163adb6..01bac223 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -18,6 +18,8 @@ open Properties +(** {1 Type and pretty printers } *) + (** a file descriptor with properties Upper bounds are avoided here so that this type can be used in functors *) @@ -35,11 +37,16 @@ val pp : _ t Fmt.t 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. +(** {1 Initialization} *) + +val setup : unit -> unit +(** [setup ()] installs a SIGPIPE handler. + + By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. *) +(** {1 With resource wrappers} *) + 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. @@ -53,6 +60,13 @@ module Syntax : sig (** [let@ fd = with_fd t in ... use fd] *) end +(** {1 {!mod:Unix} wrappers} *) + +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 pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make (** [pipe ()] creates an unnamed pipe. @see {!val:Unix.pipe} @@ -177,6 +191,8 @@ val clear_nonblock : _ t -> unit @see {!Unix.clear_nonblock} *) +(** {1 Temporary files} *) + 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. @@ -200,9 +216,6 @@ val with_temp_blk : @param delay_write_ms delays write operations by specified milliseconds *) -val setup : unit -> unit -(** [setup ()] installs a SIGPIPE handler *) - (**/**) module For_test : sig diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml index 1a60015f..9e359a9b 100644 --- a/lib/xapi-fdcaps/properties.ml +++ b/lib/xapi-fdcaps/properties.ml @@ -59,8 +59,7 @@ let to_unix_kind = | #sock -> S_SOCK -let pp_kind fmt = - Fmt.using to_unix_kind Safefd.pp_kind fmt +let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt let pp fmt = Fmt.( From e54cde24a4c4c900773631425d327e13200884af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 13:45:09 +0000 Subject: [PATCH 09/15] fixup! CP-47001: [xapi-fdcaps]: add properties module and tests --- lib/xapi-fdcaps/test/dune | 1 - lib/xapi-fdcaps/test/properties.t | 20 ++++++-------------- 2 files changed, 6 insertions(+), 15 deletions(-) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index b8d21788..50585275 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -6,5 +6,4 @@ (cram (deps (package xapi-fdcaps)) - (enabled_if (= %{ocaml_version} 4.14.1)) ) diff --git a/lib/xapi-fdcaps/test/properties.t b/lib/xapi-fdcaps/test/properties.t index 52fcd066..51b37e0e 100644 --- a/lib/xapi-fdcaps/test/properties.t +++ b/lib/xapi-fdcaps/test/properties.t @@ -2,22 +2,14 @@ Check that we get compile errors when trying to use a read-only or write-only pr $ cat >t.ml <<'EOF' > open Xapi_fdcaps.Properties - > let _ = as_readable (make `wronly `reg) in () + > let _ = as_readable (make `wronly `reg) > EOF - $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml - File "t.ml", line 2, characters 40-42: - 2 | let _ = as_readable (make `wronly `reg) in () - ^^ - Error: Syntax error - [2] + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `wronly $ cat >t.ml <<'EOF' > open Xapi_fdcaps.Properties - > let _ = as_writable (make `rdonly `reg) in () + > let _ = as_writable (make `rdonly `reg) > EOF - $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml - File "t.ml", line 2, characters 40-42: - 2 | let _ = as_writable (make `rdonly `reg) in () - ^^ - Error: Syntax error - [2] + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `rdonly From 831010ffb8b17d8fb4f5407ba4e8ebb54011bd4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 16:59:49 +0000 Subject: [PATCH 10/15] fixup! CP-47001: [xapi-fdcaps]: optional coverage support --- dune-project | 2 +- xapi-fdcaps.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index d3b8f170..f5319e7e 100644 --- a/dune-project +++ b/dune-project @@ -116,7 +116,7 @@ (alcotest :with-test) base-unix fmt - (bisect_ppx :build) + (bisect_ppx :with-test) ) ) diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam index fffa27cc..4833fbb1 100644 --- a/xapi-fdcaps.opam +++ b/xapi-fdcaps.opam @@ -11,7 +11,7 @@ depends: [ "alcotest" {with-test} "base-unix" "fmt" - "bisect_ppx" {build} + "bisect_ppx" {with-test} "odoc" {with-doc} ] build: [ From d2fac7979eee8a834c06d28392b25687fe8682f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 17:04:37 +0000 Subject: [PATCH 11/15] fixup! CP-47001: [xapi-fdcaps]: add operations module and tests --- lib/xapi-fdcaps/operations.ml | 3 +-- lib/xapi-fdcaps/operations.mli | 11 ++--------- 2 files changed, 3 insertions(+), 11 deletions(-) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 4b1580ab..12e74d60 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -173,8 +173,7 @@ let check_output cmd args = | _ -> failwith (Printf.sprintf "%s exited nonzero" cmd) -let with_temp_blk ?(sector_size = 512) ?delay_read_ms:_ ?delay_write_ms:_ name f - = +let with_temp_blk ?(sector_size = 512) name f = let blkdev = check_output "losetup" [ diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index 01bac223..e320c681 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -199,21 +199,14 @@ val with_tempfile : 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. + ?sector_size:int -> 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]. 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 *) (**/**) From ab54dc4ff11f2c6ddd2f6e5592db9ade1f509675 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 13:44:26 +0000 Subject: [PATCH 12/15] CP-47001: [xapi-fdcaps]: wrap more Unix operations --- lib/xapi-fdcaps/operations.ml | 79 +++++++++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 57 ++++++++++++++++++ lib/xapi-fdcaps/properties.ml | 18 ++++++ lib/xapi-fdcaps/properties.mli | 3 + lib/xapi-fdcaps/test/test_operations.ml | 41 +++++++++++++ 5 files changed, 198 insertions(+) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 12e74d60..7f7c9067 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -56,6 +56,8 @@ let pp ppf = let close t = Safefd.idempotent_close_exn t.fd +let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) + let with_fd t f = let finally () = close t in Fun.protect ~finally (fun () -> f t) @@ -107,6 +109,14 @@ let creat path flags perm = (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags) perm +let kind_of_fd fd = of_unix_kind Unix.LargeFile.((fstat fd).st_kind) + +let stdin = make_ro_exn (kind_of_fd Unix.stdin) Unix.stdin + +let stdout = make_wo_exn (kind_of_fd Unix.stdout) Unix.stdout + +let stderr = make_wo_exn (kind_of_fd Unix.stderr) Unix.stderr + let dev_null_out () = openfile_wo `chr "/dev/null" [] let dev_null_in () = openfile_ro `chr "/dev/null" [] @@ -122,6 +132,9 @@ let shutdown_send t = let shutdown_all t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL +let setsockopt_float t opt value = + Unix.setsockopt_float (Safefd.unsafe_to_file_descr_exn t.fd) opt value + let ftruncate t size = match t.custom_ftruncate with | None -> @@ -138,6 +151,18 @@ let read t 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 fstat t = Unix.LargeFile.fstat (Safefd.unsafe_to_file_descr_exn t.fd) + +let dup t = + { + t with + fd= + t.fd + |> Safefd.unsafe_to_file_descr_exn + |> Unix.dup + |> Safefd.of_file_descr + } + 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) @@ -200,6 +225,60 @@ let with_temp_blk ?(sector_size = 512) name f = let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +let repeat_read op fd buf off len = + let rec loop consumed = + let off = off + consumed and len = len - consumed in + if len = 0 then + consumed (* we filled the buffer *) + else + match op fd buf off len with + | 0 (* EOF *) + | (exception + Unix.( + Unix_error + ((ECONNRESET | ENOTCONN | EAGAIN | EWOULDBLOCK | EINTR), _, _)) + ) (* connection error or non-blocking socket *) -> + consumed + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (consumed + n) + in + loop 0 + +let repeat_write op fd buf off len = + let rec loop written = + let off = off + written and len = len - written in + if len = 0 then + written (* we've written the entire buffer *) + else + match op fd buf off len with + | 0 + (* should never happen, but we cannot retry now or we'd enter an infinite loop *) + | (exception + Unix.( + Unix_error + ( ( ECONNRESET + | EPIPE + | EINTR + | ENETDOWN + | ENETUNREACH + | EAGAIN + | EWOULDBLOCK ) + , _ + , _ + )) + ) (* connection error or nonblocking socket *) -> + written + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (written + n) + in + loop 0 + 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 index e320c681..ee4a9f36 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -62,11 +62,26 @@ end (** {1 {!mod:Unix} wrappers} *) +val stdin : ([> rdonly], kind) make +(** [stdin] is a readonly file descriptor of unknown kind *) + +val stdout : ([> wronly], kind) make +(** [stdout] is a writeonly file descriptor of unknown kind *) + +val stderr : ([> wronly], kind) make +(** [stderr] is a writeonly file descriptor of unknown kind *) + 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 fsync : _ t -> unit +(** [fsync t] flushes [t] buffer to disk. + + Note that the file doesn't necessarily have to be writable, e.g. you can fsync a readonly open directory. + *) + val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make (** [pipe ()] creates an unnamed pipe. @see {!val:Unix.pipe} @@ -173,6 +188,12 @@ val single_write_substring : @see {!Unix.single_write_substring} *) +val fstat : _ t -> Unix.LargeFile.stats +(** [fstat t] is {!val:Unix.LargeFile.fstat} *) + +val dup : 'a t -> 'a t +(** [dup t] is {!val:Unix.dup} on [t]. *) + val set_nonblock : (_, [< espipe]) make -> unit (** [set_nonblock t]. @@ -191,6 +212,10 @@ val clear_nonblock : _ t -> unit @see {!Unix.clear_nonblock} *) +val setsockopt_float : + (_, [< sock]) make -> Unix.socket_float_option -> float -> unit +(** [set_sockopt_float t opt val] sets the socket option [opt] to [val] for [t]. *) + (** {1 Temporary files} *) val with_tempfile : @@ -209,6 +234,38 @@ val with_temp_blk : @param sector_size between 512 and 4096 *) +(** {1 Operation wrappers} + + The low-level {!val:read} and {!val:single_write_substring} can raise different exceptions + to mean end-of-file/disconnected depending on the file's kind. + + If you want to consider disconnectins as end-of-file then use these wrappers. + *) + +(** a buffered operation on a file descriptors. + + @see {!val:read} and {!val:single_write_substring} + *) +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +val repeat_read : ('a, bytes) operation -> ('a, bytes) operation +(** [repeat_read op buf off len] repeats [op] on the supplied buffer until EOF or a connection error is encountered. + The following connection errors are treated as EOF and are not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.ENOTCONN}. + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if EOF was encountered. +*) + +val repeat_write : ('a, string) operation -> ('a, string) operation +(** [repeat_write op buf off len] repeats [op] on the supplied buffer until a connection error is encountered or the entire buffer is written. + The following are treated as connection errors and not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.EPIPE}, {!val:Unix.ENETDOWN}, {!val:Unix.ENETUNREACH} + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if we were not able to complete the write due to a connection error. +*) + (**/**) module For_test : sig diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml index 9e359a9b..d26194cf 100644 --- a/lib/xapi-fdcaps/properties.ml +++ b/lib/xapi-fdcaps/properties.ml @@ -59,6 +59,24 @@ let to_unix_kind = | #sock -> S_SOCK +let of_unix_kind = + let open Unix in + function + | S_REG -> + `reg + | S_BLK -> + `blk + | S_CHR -> + `chr + | S_DIR -> + `dir + | S_LNK -> + `lnk + | S_FIFO -> + `fifo + | S_SOCK -> + `sock + let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt let pp fmt = diff --git a/lib/xapi-fdcaps/properties.mli b/lib/xapi-fdcaps/properties.mli index 0afc529c..6b51a3ab 100644 --- a/lib/xapi-fdcaps/properties.mli +++ b/lib/xapi-fdcaps/properties.mli @@ -161,6 +161,9 @@ val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option val to_unix_kind : kind -> Unix.file_kind (** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) +val of_unix_kind : Unix.file_kind -> kind +(** [of_unix_kind kind] converts the {!type:Unix.file_kind} to {!type:kind}. *) + (** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) type espipe = [fifo | sock] diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml index f3c22f36..fa60e5f6 100644 --- a/lib/xapi-fdcaps/test/test_operations.ml +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -227,6 +227,45 @@ let test_creat () = let@ fd2 = with_fd @@ openfile_rw `reg name [] in pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 +let test_repeat_read () = + let buf = String.init 255 Char.chr in + let read _ dst off len = + let available = String.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string buf off dst off len ; + len + in + let dst = Bytes.make 300 '_' in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_read read placeholder dst 0 (Bytes.length dst) in + Alcotest.(check' int) ~msg:"amount read" ~actual ~expected:(String.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string dst 0 actual) + ~expected:buf + +let test_repeat_write () = + let buf = Bytes.make 255 '_' in + let write _ src off len = + let available = Bytes.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string src off buf off len ; + len + in + let src = String.init 255 Char.chr in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_write write placeholder src 0 (String.length src) in + Alcotest.(check' int) + ~msg:"amount written" ~actual ~expected:(Bytes.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string buf 0 actual) + ~expected:src + let tests = Alcotest. [ @@ -238,6 +277,8 @@ let tests = ; 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 + ; test_case "repeat_read" `Quick test_repeat_read + ; test_case "repeat_write" `Quick test_repeat_write ] (* this must be the last test *) From 7c3ce31d3b84fdb3f4a80365f09dcf4f4e1c2cbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 13:58:26 +0000 Subject: [PATCH 13/15] CP-47001: [xapi-fdcaps] runtime tests for read-write properties MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 31 +++++++++++++++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 23 +++++++++++++++++++++++ 2 files changed, 54 insertions(+) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 7f7c9067..bce25cdc 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -58,6 +58,29 @@ 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_opt t = + match as_readable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_writable_opt t = + match as_writable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_spipe_opt t = + match + (Properties.as_kind_opt `sock t.props, Properties.as_kind_opt `fifo t.props) + with + | Some props, _ | _, Some props -> + Some {t with props} + | None, None -> + None + let with_fd t f = let finally () = close t in Fun.protect ~finally (fun () -> f t) @@ -129,6 +152,14 @@ let shutdown_recv t = let shutdown_send t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND +let as_readonly_socket t = + shutdown_send t ; + {t with props= Properties.make `rdonly `sock} + +let as_writeonly_socket t = + shutdown_recv t ; + {t with props= Properties.make `wronly `sock} + let shutdown_all t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index ee4a9f36..6097f8cd 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -45,6 +45,19 @@ val setup : unit -> unit By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. *) +(** {1 Runtime property tests} *) + +val as_readable_opt : + (([< rw] as 'a), 'b) make -> ([> readable], 'b) make option +(** [as_readable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_writable_opt : + (([< rw] as 'a), 'b) make -> ([> writable], 'b) make option +(** [as_writable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_spipe_opt : ('a, [< kind]) make -> ('a, [> espipe]) make option +(** [as_spipe_opt t] returns [Some t] when [t] is a socket or pipe, and [None] otherwise. *) + (** {1 With resource wrappers} *) val with_fd : 'a t -> ('a t -> 'b) -> 'b @@ -158,6 +171,16 @@ val shutdown_send : ([< writable], [< sock]) make -> unit @see {!Unix.shutdown} *) +val as_readonly_socket : + ([< readable], [< sock]) make -> ([> rdonly], [> sock]) make +(** [as_readonly_socket t] calls {!val:shutdown_send} and returns a readonly socket, + if it was originally readable. *) + +val as_writeonly_socket : + ([< writable], [< sock]) make -> ([> wronly], [> sock]) make +(** [as_writeonly_socket t] calls {!val:shutdown_recv} and returns a writeonly socket, + if it was originally readable. *) + val shutdown_all : ([< rdwr], [< sock]) make -> unit (** [shutdown_all t] shuts down both receiving and sending on [t]. From a7bb4e969a58ce75586aba377b77a784247e3e42 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 13:58:50 +0000 Subject: [PATCH 14/15] CP-47001: [xapi-fdcaps-test]: add observations module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It can be used to wrap read or write operations andobserve the data that is transferred, and elapsed time. It also provides 2 functions that create a file of a given kind. We only test UNIX sockets, because socketpair doesn't support TCP sockets on Linux. Signed-off-by: Edwin Török --- lib/xapi-fd-test/dune | 5 +- lib/xapi-fd-test/observations.ml | 273 +++++++++++++++++++++ lib/xapi-fd-test/observations.mli | 180 ++++++++++++++ lib/xapi-fd-test/test/dune | 2 +- lib/xapi-fd-test/test/test_xapi_fd_test.ml | 113 +++++++++ 5 files changed, 571 insertions(+), 2 deletions(-) create mode 100644 lib/xapi-fd-test/observations.ml create mode 100644 lib/xapi-fd-test/observations.mli diff --git a/lib/xapi-fd-test/dune b/lib/xapi-fd-test/dune index b2a0d2fe..4ae4d8d5 100644 --- a/lib/xapi-fd-test/dune +++ b/lib/xapi-fd-test/dune @@ -2,5 +2,8 @@ (library (public_name xapi-fd-test) (name xapi_fd_test) - (libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os) + (libraries (re_export xapi-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/lib/xapi-fd-test/observations.ml b/lib/xapi-fd-test/observations.ml new file mode 100644 index 00000000..6bdfdf58 --- /dev/null +++ b/lib/xapi-fd-test/observations.ml @@ -0,0 +1,273 @@ +open Xapi_fdcaps +open Properties +open Operations +open Syntax + +let open_ro name = openfile_ro `reg name [] + +let open_wo name = openfile_wo `reg name [] + +let with_kind_ro kind f = + let with2 t = + let@ fd1, fd2 = with_fd2 t in + f fd1 (Some fd2) + in + match kind with + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f (as_readonly_socket fd1) (Some fd2) + | Unix.S_REG -> + let@ name, out = with_tempfile () in + let@ fd = with_fd @@ open_ro name in + f fd (Some out) + | Unix.S_FIFO -> + with2 (pipe ()) + | Unix.S_DIR -> + invalid_arg + "S_DIR" (* not supported, OCaml has separate dir_handle type *) + | Unix.S_LNK -> + invalid_arg "S_LNK" (* O_NOFOLLOW not bound in OCaml *) + | Unix.S_BLK -> + let@ name, out = with_tempfile ~size:512L () in + let@ blkname, _ = with_temp_blk name in + let@ fd = with_fd @@ open_ro blkname in + f fd (Some out) + | Unix.S_CHR -> + let@ fd = with_fd @@ dev_zero () in + f fd None + +let with_kind_wo kind f = + let with2 t = + let@ fd1, fd2 = with_fd2 t in + f fd2 (Some fd1) + in + match kind with + | Unix.S_REG -> + let@ name, _out = with_tempfile () in + let@ fd = with_fd @@ open_wo name in + let@ fd_ro = with_fd @@ open_ro name in + f fd (Some fd_ro) + | Unix.S_FIFO -> + with2 @@ pipe () + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f (as_writeonly_socket fd2) (Some fd1) + | Unix.S_DIR -> + invalid_arg + "S_DIR" (* not supported, OCaml has separate dir_handle type *) + | 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@ blkname, _ = with_temp_blk name in + let@ fd_ro = with_fd @@ open_ro blkname in + let@ fd = with_fd @@ open_wo blkname in + f fd (Some fd_ro) + | Unix.S_CHR -> + let@ fd = with_fd @@ dev_null_out () in + f fd None + +let with_kind_rw kind f = + match kind with + | 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" + +let observe_read observed op t dest off len = + let amount = op t dest off len in + assert (amount >= 0) ; + Buffer.add_subbytes observed dest off amount ; + amount + +let observe_write observed op t source off len = + let amount = op t source off len in + assert (amount >= 0) ; + Buffer.add_substring observed source off amount ; + amount + +type 'a or_exn = ('a, Rresult.R.exn_trap) result + +let unwrap_exn = function + | Ok ok -> + ok + | Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + +let concurrently (f, g) (farg, garg) = + (* only one thread at a time reads or writes, atomic not needed *) + let thread_result = ref None in + let thread_fun (tfun, arg) = + thread_result := Some (Rresult.R.trap_exn tfun arg) + in + let t = Thread.create thread_fun (g, garg) in + let res = Rresult.R.trap_exn f farg in + Thread.join t ; + let thread_result = + match !thread_result with + | Some r -> + r + | None -> + Rresult.R.trap_exn failwith "Thread not run?" + in + (res, thread_result) + +type 'a observation = { + elapsed: Mtime.span + ; data: string + ; is_read: [< rdonly | wronly] as 'a +} + +let pp ppf = + Fmt.( + record + [ + field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ; field "data" (fun t -> t.data) string + ] + ) + ppf + +type ('a, 'b) observations = {read: 'a; write: 'b; elapsed: Mtime.span} + +module CancellableSleep = struct + type nonrec t = { + wait: (rdonly, sock) make + ; wake: (wronly, sock) make + ; buf: bytes + } + + let with_ f = + let@ wait, wake = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f + { + wait= as_readonly_socket wait + ; wake= as_writeonly_socket wake + ; buf= Bytes.make 1 ' ' + } + + let set_rcvtimeo sock timeo = setsockopt_float sock Unix.SO_RCVTIMEO timeo + + let sleep t dt = + set_rcvtimeo t.wait (Mtime.Span.to_float_ns dt *. 1e-9) ; + try + let (_ : int) = read t.wait t.buf 0 1 in + () + with Unix.Unix_error (Unix.EAGAIN, _, _) -> () + + let cancel t = shutdown_send t.wake +end + +module Delay = struct + type t = {duration: Mtime.span; every_bytes: int} + + let pp = + Fmt.( + record + [ + field "duration" (fun t -> t.duration) Mtime.Span.pp + ; field "every_bytes" (fun t -> t.every_bytes) int + ] + ) + + let v ~duration ~every_bytes = {duration; every_bytes} + + let apply repeat cancel t op = + let remaining = ref t.every_bytes in + let sleep () = + CancellableSleep.sleep cancel t.duration ; + remaining := t.every_bytes + in + let delayed_op fd buf off len = + (* ensure we'll be able to insert our sleep, limit [len] if needed *) + let n = op fd buf off (Int.min !remaining len) in + remaining := !remaining - n ; + if !remaining <= 0 then sleep () ; + n + in + repeat delayed_op + + let apply_read cancel t op = apply repeat_read cancel t op + + let apply_write cancel t op = apply repeat_write cancel t op +end + +let do_op buf is_read repeat observe op arg off length fd = + fd + |> Option.map @@ fun rd -> + let dt = Mtime_clock.counter () in + let (_ : int) = repeat (observe buf op) rd arg off length in + let elapsed = Mtime_clock.count dt in + let data = Buffer.contents buf in + {is_read; data; elapsed} + +let do_read read rd_buf = + let length = 65536 in + do_op rd_buf `rdonly repeat_read observe_read read (Bytes.make length 'x') 0 + length + +let do_write write buf expected off = + do_op buf `wronly repeat_write observe_write write expected off + (String.length expected - off) + +let wrap_measure f arg = + let dt = Mtime_clock.counter () in + let r = Rresult.R.trap_exn f arg in + (Mtime_clock.count dt, r) + +let observe_ro write ~f kind expected = + with_kind_ro kind @@ fun ro wo_opt -> + let written = Buffer.create 0 in + let prepare fd_opt = + let () = + fd_opt + |> Option.iter @@ fun fd -> + as_spipe_opt fd |> Option.iter set_nonblock ; + let (_ : int) = + repeat_write + (observe_write written write) + fd expected 0 (String.length expected) + in + clear_nonblock fd + in + Buffer.length written + in + (* write as much as possible initially, TODO: should be configurable? *) + let off = prepare wo_opt in + let g fd_opt = + fd_opt + |> Option.fold ~none:None ~some:(fun fd -> + do_write write written expected off (as_writable_opt fd) + ) + in + let res, thread_result = concurrently (wrap_measure f, g) (ro, wo_opt) in + let elapsed, res = unwrap_exn res in + let write = unwrap_exn thread_result in + let write = + write + |> Option.map @@ fun write -> {write with data= Buffer.contents written} + in + ({read= (); write; elapsed}, res) + +let observe_wo read ~f kind = + with_kind_wo kind @@ fun wo ro_opt -> + let rd_buf = Buffer.create 0 in + (* TODO:set block device size *) + let g fd_opt = + fd_opt + |> Option.fold ~none:None ~some:(fun fd -> + do_read read rd_buf (as_readable_opt fd) + ) + in + let res, thread_result = concurrently (wrap_measure f, g) (wo, ro_opt) in + let elapsed, res = unwrap_exn res in + let read = unwrap_exn thread_result in + let (_ : _ option) = g ro_opt in + let read = + read |> Option.map @@ fun read -> {read with data= Buffer.contents rd_buf} + in + ({write= (); read; elapsed}, res) diff --git a/lib/xapi-fd-test/observations.mli b/lib/xapi-fd-test/observations.mli new file mode 100644 index 00000000..99047f4c --- /dev/null +++ b/lib/xapi-fd-test/observations.mli @@ -0,0 +1,180 @@ +(* + * 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 + +(** {1 Generate test resources} *) + +val with_kind_ro : + Unix.file_kind + -> (([> rdonly], kind) make -> ([> writable], kind) make option -> 'a) + -> 'a +(** [with_kind_ro kind f] creates file descriptors of [kind] type, and calls [f] with it. + For sockets and pipes [f] receives both sides. + For regular files and block devices it receives a writable file. + For character devices it receives a {!val:null} device. +*) + +val with_kind_wo : + Unix.file_kind + -> (([> wronly], kind) make -> ([> readable], kind) make option -> 'a) + -> 'a +(** [with_kind_wo kind f] is like {!val:with_kind_ro} but creates a write only file. +*) + +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. +*) + +(** {1 Observe operations} *) + +val observe_read : + Buffer.t + -> ((([< readable], _) Properties.t as 'a), bytes) operation + -> ('a, bytes) operation +(** [observe_read buf op] wraps the operation [op], and stores all substrings read into [buf]. *) + +val observe_write : + Buffer.t + -> ((([< writable], _) Properties.t as 'a), string) operation + -> ('a, string) operation +(** [observe_write buf op] wraps the operation [op], and stores all substrings written into [buf]. *) + +(** {1 Concurrency helpers} *) + +(** a successful result ['a], or an exception with its backtrace on error. + +@see {!val:unwrap_exn} to reraise the exception with its original backtrace + *) +type 'a or_exn = ('a, Rresult.R.exn_trap) result + +val unwrap_exn : 'a or_exn -> 'a +(** [unwrap_exn t] returns the underlying successful result, or reraises the exception *) + +val concurrently : ('a -> 'b) * ('c -> 'd) -> 'a * 'c -> 'b or_exn * 'd or_exn +(** [concurrently (f, g) (farg, garg)] calls [f farg] and [g garg] in separate threads, + and returns their results. +*) + +(** Sleep that can be interrupted from another thread. + + This uses file descriptors internally, so shouldn't be used as is in XAPI, + because it'd use up 2 file descriptors every time a [with_] is called. + + `pthread_cond_timedwait` could've been used instead, but that is not available in OCaml, + and `pthread_cond*` is known to have deadlock bugs on glibc >= 2.27 + https://sourceware.org/bugzilla/show_bug.cgi?id=25847 +*) +module CancellableSleep : sig + (** cancel signal *) + type t + + val with_ : (t -> 'a) -> 'a + (** [with f] creates a cancellable sleep value and calls [f] with it. *) + + val sleep : t -> Mtime.span -> unit + (** [sleep t duration] sleeps until [duration] has elapsed or [t] has been signaled. *) + + val cancel : t -> unit + (** [cancel t] signals [t] to cancel any sleeps *) +end + +(** 1 Introduce delays + +These are needed to trigger short reads on sockets. +*) + +module Delay : sig + (** a delay specification *) + type t + + val v : duration:Mtime.span -> every_bytes:int -> t + (** [v ~duration ~every_bytes] inserts a sleep for [duration] every [every_bytes] interval. + The sleep can be canceled with [cancel]. + + Note that the time taken to send or receive [after_bytes] is not taken into account to guarantee the insertion of the delay. + *) + + val apply_read : + CancellableSleep.t + -> t + -> ((([< readable], _) Properties.t as 'a), bytes) operation + -> ('a, bytes) operation + (** [apply_read cancel delay op] returns a new operation which calls [op] and every [delay.after_bytes] + calls sleep for [duration] *) + + val apply_write : + CancellableSleep.t + -> t + -> ((([< writable], _) Properties.t as 'a), string) operation + -> ('a, string) operation + (** [apply_write cancel delay op] returns a new operation which calls [op] and every [delay.after_bytes] + calls sleep for [duration] *) + + val pp : t Fmt.t + (** [pp formatter t] is a pretty printer for [t] on [formatter]. *) +end + +(** {1 Observe file descriptor actions} + + File descriptors are created in pairs, and we can observe the actions from the other end of a pipe or socketpair. + For regular files we can prepare some data before, or inspect the data at the end. + *) + +(** an observation from the point of view of the observer *) +type 'a observation = { + elapsed: Mtime.span + (** the elapsed time for the observer until EOF was encountered *) + ; data: string (** the data that was sent or received *) + ; is_read: [< rdonly | wronly] as 'a + (** observer's point of view, so observing actions on a readonly pipe will be a write action *) +} + +val pp : _ observation Fmt.t +(**[pp formatter obs] pretty prints [obs]ervation on [formatter]. *) + +(** read and write observations, and the time elapsed for the function under test *) +type ('a, 'b) observations = {read: 'a; write: 'b; elapsed: Mtime.span} + +val observe_ro : + (([> writable], kind) Properties.t, string) operation + -> f:(([< readable > `rdonly], kind) make -> 'a) + -> Unix.file_kind + -> string + -> (unit, [> wronly] observation option) observations * 'a or_exn +(** [observe_ro write ~f kind expected] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + + @param write the operation used for writing, allows insertion of delays + @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 + *) + +val observe_wo : + (([> readable], kind) Properties.t, bytes) operation + -> f:(([< writable > `wronly], kind) make -> 'a) + -> Unix.file_kind + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [observe_wo read ~f kind] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + + @returns an observation of [f]'s actions on the file descriptor and [f]'s result + *) diff --git a/lib/xapi-fd-test/test/dune b/lib/xapi-fd-test/test/dune index 10b800a0..ecc23b14 100644 --- a/lib/xapi-fd-test/test/dune +++ b/lib/xapi-fd-test/test/dune @@ -2,5 +2,5 @@ (test (package xapi-fd-test) (name test_xapi_fd_test) - (libraries xapi_fd_test alcotest) + (libraries xapi_fd_test alcotest fmt mtime.clock.os) ) diff --git a/lib/xapi-fd-test/test/test_xapi_fd_test.ml b/lib/xapi-fd-test/test/test_xapi_fd_test.ml index e69de29b..1e28ffed 100644 --- a/lib/xapi-fd-test/test/test_xapi_fd_test.ml +++ b/lib/xapi-fd-test/test/test_xapi_fd_test.ml @@ -0,0 +1,113 @@ +open Xapi_fdcaps +open Operations +open Xapi_fd_test.Observations +open Syntax + +let skip_blk = function + | Unix.S_BLK -> + if Unix.geteuid () <> 0 then + Alcotest.skip () + | _ -> + () + +let expected = "string to be written" + +let prepare fd_opt = + let buf = Buffer.create 0 in + let () = + fd_opt + |> Option.iter @@ fun fd -> + let (_ : int) = + observe_write buf single_write_substring fd expected 0 + (String.length expected) + in + () + in + buf + +let test_kind_ro kind () = + skip_blk kind ; + let f fd = + let b = Bytes.make 128 'x' in + let n = read fd b 0 (Bytes.length b) in + close fd ; Bytes.sub_string b 0 n + in + let observed, res = observe_ro single_write_substring kind expected ~f in + let actual = unwrap_exn res in + match observed.write with + | Some observed_write -> + Alcotest.(check' string) + ~msg:"expected string received" ~expected:observed_write.data ~actual + | None -> + () + +let test_kind_wo kind () = + skip_blk kind ; + let f fd = + let n = single_write_substring fd expected 0 (String.length expected) in + close fd ; String.sub expected 0 n + in + let observed, res = observe_wo read kind ~f in + let actual = unwrap_exn res in + match observed.read with + | Some observed_read -> + Alcotest.(check' string) + ~msg:"expected string received" ~expected:observed_read.data ~actual + | None -> + () + +let kinds = Unix.[S_BLK; S_CHR; S_FIFO; S_REG; S_SOCK] + +let test_kind_all test = + kinds + |> List.map @@ fun kind -> + Alcotest.test_case (Fmt.to_to_string Safefd.pp_kind kind) `Quick (test kind) + +let test_cancellable_sleep () = + let@ t = CancellableSleep.with_ in + let sleep_duration = Mtime.Span.(2 * s) in + let sleeper () = + let dt = Mtime_clock.counter () in + let () = CancellableSleep.sleep t sleep_duration in + Mtime_clock.count dt + in + let waker_duration = 0.1 in + let waker () = Unix.sleepf waker_duration ; CancellableSleep.cancel t in + let slept, _ = concurrently (sleeper, waker) ((), ()) in + let slept = unwrap_exn slept in + if Mtime.Span.compare slept sleep_duration >= 0 then + Alcotest.failf + "Sleep wasn't interrupted as expected, total duration = %a; waked at = \ + %fs" + Mtime.Span.pp slept waker_duration ; + if Mtime.Span.to_float_ns slept *. 1e-9 < waker_duration then + Alcotest.failf "Sleep was shorter than expected, total duration = %a < %fs" + Mtime.Span.pp slept waker_duration + +let test_full_sleep () = + let@ t = CancellableSleep.with_ in + let sleep_duration = Mtime.Span.(10 * ms) in + let slept = + let dt = Mtime_clock.counter () in + let () = CancellableSleep.sleep t sleep_duration in + Mtime_clock.count dt + in + if Mtime.Span.compare slept sleep_duration < 0 then + Alcotest.failf "Sleep was shorter than expected, total duration = %a < %a" + Mtime.Span.pp slept Mtime.Span.pp sleep_duration + +let () = + setup () ; + (* kill test after 5s, it must've gotten stuck.. *) + (* let (_: int) = Unix.alarm 5 in *) + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("test_kind_ro", test_kind_all test_kind_ro) + ; ("test_kind_wo", test_kind_all test_kind_wo) + ; ( "cancellable sleep" + , [ + Alcotest.test_case "cancellable" `Quick test_cancellable_sleep + ; Alcotest.test_case "full" `Quick test_full_sleep + ] + ) + ] From 20c69ea70c3f1958c748ee43f786a4c100973336 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 17:05:01 +0000 Subject: [PATCH 15/15] CP-47001: [xapi-fdcaps-test]: add generate module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fd-test/generate.ml | 114 ++++++++++++++++++++++++++++++++++ lib/xapi-fd-test/generate.mli | 75 ++++++++++++++++++++++ 2 files changed, 189 insertions(+) create mode 100644 lib/xapi-fd-test/generate.ml create mode 100644 lib/xapi-fd-test/generate.mli diff --git a/lib/xapi-fd-test/generate.ml b/lib/xapi-fd-test/generate.ml new file mode 100644 index 00000000..23060ff9 --- /dev/null +++ b/lib/xapi-fd-test/generate.ml @@ -0,0 +1,114 @@ +(* + * 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 Operations +open Observations + +type t = { + size: int + ; delay_read: Delay.t option + ; delay_write: Delay.t option + ; kind: Unix.file_kind +} + +let make ~size ~delay_read ~delay_write kind = + {size; delay_read; delay_write; kind} + +open QCheck2 + +let file_kind = + ( Gen.oneofa Unix.[|S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK|] + , Print.contramap (Fmt.to_to_string Safefd.pp_kind) Print.string + ) + +(* also coincidentally the pipe buffer size on Linux *) +let ocaml_unix_buffer_size = 65536 + +let sizes = + Gen.oneofa + [| + 0 + ; 1 + ; 100 + ; 4096 + ; ocaml_unix_buffer_size - 1 + ; ocaml_unix_buffer_size + ; ocaml_unix_buffer_size + 1 + ; 2 * ocaml_unix_buffer_size + ; (10 * ocaml_unix_buffer_size) + 3 + |] + +(* some may exceed length of test, but that is what the timeout is for *) +let delays = Gen.oneofa [|0.001; 0.01; 0.1; 1.0|] + +let span_of_s s = s *. 1e9 |> Mtime.Span.of_float_ns |> Option.get + +let delays = + let build duration every_bytes = Delay.v ~duration ~every_bytes in + (* order matters here for shrinking: shrink timeout first so that shrinking completes sooner! *) + Gen.(map2 build (map span_of_s delays) (1 -- 128000)) + +(* keep these short *) +let timeouts = Gen.oneofa [|0.0; 0.001; 0.1; 0.3|] + +let t = + let build (delay_read, delay_write, size, kind) = + make ~delay_read ~delay_write ~size kind + in + Gen.(map build @@ tup4 (option delays) (option delays) sizes (fst file_kind)) + +let print = + Fmt.to_to_string + @@ Fmt.( + record + [ + field "delay_read" (fun t -> t.delay_read) (option Delay.pp) + ; field "delay_write" (fun t -> t.delay_write) (option Delay.pp) + ; field "size" (fun t -> t.size) int + ; field "file_kind" (fun t -> (snd file_kind) t.kind) string + ] + ) + +let run_ro t data ~f = + if Option.is_some t.delay_read then + QCheck2.assume_fail () ; + (* we can only implement delays on write, skip *) + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let write = + match t.delay_write with + | Some delay -> + Delay.apply_write cancel delay single_write_substring + | None -> + single_write_substring + in + observe_ro write ~f t.kind data + +let run_wo t ~f = + if Option.is_some t.delay_write then + QCheck2.assume_fail () ; + (* we can only implement delays on write, skip *) + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let read = + match t.delay_read with + | Some delay -> + Delay.apply_read cancel delay read + | None -> + read + in + observe_wo read ~f t.kind diff --git a/lib/xapi-fd-test/generate.mli b/lib/xapi-fd-test/generate.mli new file mode 100644 index 00000000..45a3988c --- /dev/null +++ b/lib/xapi-fd-test/generate.mli @@ -0,0 +1,75 @@ +(* + * 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 Observations + +(** file descriptor behaviour specification *) +type t = { + size: int + ; delay_read: Delay.t option + ; delay_write: Delay.t option + ; kind: Unix.file_kind +} + +val timeouts : float QCheck2.Gen.t +(** [timeouts] is a generator for small timeouts *) + +val make : + size:int + -> delay_read:Delay.t option + -> delay_write:Delay.t option + -> Unix.file_kind + -> t +(** [make ~size ~delay_read ~delay_write kind] is a file descriptor test. + + @param size the size of the file, or the amount of data sent on a socket/pipe + @param delay_read whether to insert sleeps to trigger short reads + @param delay_write whether to insert sleeps to trigger short writes + @param kind the {!type:Unix.file_kind} of the file descriptor to create +*) + +val t : t QCheck2.Gen.t +(** [t] is a {!mod:QCheck2} generator for {!type:t}. + + This doesn't yet open any file descriptors (there'd be too many leaks and we'd run out), + that is done by {!val:run} + + Follows the naming convention to name generators after the type they generate. +*) + +val print : t QCheck2.Print.t +(** [print] is a QCheck2 pretty printer for [t] *) + +val run_ro : + t + -> string + -> f:(([< readable > `rdonly], kind) make -> 'a) + -> (unit, [> wronly] observation option) observations * 'a or_exn +(** [run_ro t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as readonly. + + @returns observations about [f]'s actions the file descriptor +*) + +val run_wo : + t + -> f:(([< writable > `wronly], kind) make -> 'a) + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [run_wo t ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as writeonly. + + @returns observations about [f]'s actions on the file descriptor +*)