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/.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 a4973b11..f5319e7e 100644 --- a/dune-project +++ b/dune-project @@ -2,6 +2,8 @@ (formatting (enabled_for ocaml)) (name xapi-stdext) +(cram enable) +(implicit_transitive_deps false) (generate_opam_files true) (source (github xapi-project/stdext)) @@ -21,6 +23,8 @@ (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) (xapi-stdext-zerocheck (= :version)) + (xapi-fdcaps (= :version)) + (xapi-fdcaps-test (and (= :version) :with-test)) ) ) @@ -104,3 +108,27 @@ (odoc :with-doc) ) ) + +(package + (name xapi-fdcaps) + (synopsis "Static capabilities for file descriptor operations") + (depends + (alcotest :with-test) + base-unix + fmt + (bisect_ppx :with-test) + ) +) + +(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..4ae4d8d5 --- /dev/null +++ b/lib/xapi-fd-test/dune @@ -0,0 +1,9 @@ +; 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 (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/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 +*) 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 new file mode 100644 index 00000000..ecc23b14 --- /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 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 new file mode 100644 index 00000000..1e28ffed --- /dev/null +++ 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 + ] + ) + ] diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune new file mode 100644 index 00000000..cb3c54ea --- /dev/null +++ b/lib/xapi-fdcaps/dune @@ -0,0 +1,11 @@ +; Keep dependencies minimal here, ideally just OCaml stdlib +; This will be used to test other functions in stdext, so it should not itself rely on other stdext libs! +(library + (public_name xapi-fdcaps) + (name xapi_fdcaps) + (libraries fmt unix threads.posix) + (flags (:standard -principal)) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) +) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml new file mode 100644 index 00000000..bce25cdc --- /dev/null +++ b/lib/xapi-fdcaps/operations.ml @@ -0,0 +1,315 @@ +(* + * 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 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) + +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 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" [] + +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 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 + +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 -> + 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 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) + +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) 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 + +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 new file mode 100644 index 00000000..6097f8cd --- /dev/null +++ b/lib/xapi-fdcaps/operations.mli @@ -0,0 +1,296 @@ +(* + * 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 + +(** {1 Type and pretty printers } *) + +(** 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]. *) + +(** {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 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 +(** [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 + +(** {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} + *) + +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 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]. + + @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 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]. + + 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 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 : + ?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 -> 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 +*) + +(** {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 + val unsafe_fd_exn : _ t -> Unix.file_descr +end diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml new file mode 100644 index 00000000..d26194cf --- /dev/null +++ b/lib/xapi-fdcaps/properties.ml @@ -0,0 +1,140 @@ +(* + * 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 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 = + 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..6b51a3ab --- /dev/null +++ b/lib/xapi-fdcaps/properties.mli @@ -0,0 +1,195 @@ +(* + * 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} *) + +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] + +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/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 new file mode 100644 index 00000000..50585275 --- /dev/null +++ b/lib/xapi-fdcaps/test/dune @@ -0,0 +1,9 @@ +(tests + (package xapi-fdcaps) + (names test_safefd test_properties test_operations) + (libraries xapi_fdcaps alcotest fmt) +) + +(cram + (deps (package xapi-fdcaps)) +) diff --git a/lib/xapi-fdcaps/test/properties.t b/lib/xapi-fdcaps/test/properties.t new file mode 100644 index 00000000..51b37e0e --- /dev/null +++ b/lib/xapi-fdcaps/test/properties.t @@ -0,0 +1,15 @@ +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) + > EOF + $ 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) + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `rdonly diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml new file mode 100644 index 00000000..fa60e5f6 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -0,0 +1,303 @@ +(* + * 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 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. + [ + 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 + ; test_case "repeat_read" `Quick test_repeat_read + ; test_case "repeat_write" `Quick test_repeat_write + ] + +(* 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]) + ] 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 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-fdcaps.opam b/xapi-fdcaps.opam new file mode 100644 index 00000000..4833fbb1 --- /dev/null +++ b/xapi-fdcaps.opam @@ -0,0 +1,31 @@ +# 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" + "bisect_ppx" {with-test} + "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: [