diff --git a/.gitignore b/.gitignore index 3e23706e3a9..768185e8a60 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ _build/ *.bak *.native .merlin +_coverage/ *.install *.swp compile_flags.txt diff --git a/Makefile b/Makefile index 0b98965e84d..d4a2b01bacf 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ JOBS = $(shell getconf _NPROCESSORS_ONLN) PROFILE=release OPTMANDIR ?= $(OPTDIR)/man/man1/ -.PHONY: build clean test doc python format install uninstall +.PHONY: build clean test doc python format install uninstall coverage # if we have XAPI_VERSION set then set it in dune-project so we use that version number instead of the one obtained from git # this is typically used when we're not building from a git repo @@ -20,6 +20,11 @@ build: check: dune build @check -j $(JOBS) +coverage: + dune runtest --instrument-with bisect_ppx --force --profile=$(RELEASE) -j $(JOBS) + bisect-ppx-report html + bisect-ppx-report summary --per-file + clean: dune clean diff --git a/dune-project b/dune-project index 747fc62b133..a43ca18d1a7 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,8 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) +(cram enable) +(implicit_transitive_deps false) (generate_opam_files true) (source (github xapi-project/xen-api)) @@ -274,6 +276,7 @@ (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) (xapi-stdext-zerocheck (= :version)) + (xapi-fdcaps (= :version)) ) ) @@ -333,6 +336,8 @@ base-unix (odoc :with-doc) (xapi-stdext-pervasives (= :version)) + (mtime :with-test) + (xapi-stdext-unix (= :version)) ) ) @@ -346,6 +351,7 @@ (odoc :with-doc) xapi-backtrace (xapi-stdext-pervasives (= :version)) + polly ) ) @@ -357,3 +363,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/ocaml/database/dune b/ocaml/database/dune index 0b0c71425ff..49bea1acfa9 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -21,6 +21,7 @@ (library (name xapi_database) + (modes best) (modules (:standard \ database_server_main db_cache_test db_names db_exn block_device_io string_marshall_helper string_unmarshall_helper schema @@ -40,6 +41,7 @@ xapi-datamodel xapi-log (re_export xapi-schema) + xapi-idl.updates xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 3d132e8ed76..160f444dd34 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -7,6 +7,7 @@ fd-send-recv rpclib.core rpclib.json + rpclib.xml uuid xapi-backtrace xapi-log diff --git a/ocaml/libs/ezxenstore/core/dune b/ocaml/libs/ezxenstore/core/dune index 2eabd6bea12..2b101fc43b3 100644 --- a/ocaml/libs/ezxenstore/core/dune +++ b/ocaml/libs/ezxenstore/core/dune @@ -7,6 +7,8 @@ logs threads uuidm - xenstore_transport - xenstore.unix) + (re_export xenstore) + (re_export xenstore_transport) + threads.posix + (re_export xenstore.unix)) ) diff --git a/ocaml/libs/ezxenstore/lib/dune b/ocaml/libs/ezxenstore/lib/dune index 65da96cc42b..874bd7e6e7f 100644 --- a/ocaml/libs/ezxenstore/lib/dune +++ b/ocaml/libs/ezxenstore/lib/dune @@ -3,7 +3,7 @@ (public_name ezxenstore) (wrapped false) (libraries - ezxenstore_core - ezxenstore_watch + (re_export ezxenstore_core) + (re_export ezxenstore_watch) ) ) diff --git a/ocaml/libs/ezxenstore/lib_test/dune b/ocaml/libs/ezxenstore/lib_test/dune index 01280a545ca..da843bf3b11 100644 --- a/ocaml/libs/ezxenstore/lib_test/dune +++ b/ocaml/libs/ezxenstore/lib_test/dune @@ -2,5 +2,5 @@ (name main) (package ezxenstore) (deps main.exe) - (libraries cmdliner ezxenstore xenstore_transport) + (libraries cmdliner ezxenstore xenstore_transport xenstore xenstore.unix) ) diff --git a/ocaml/libs/ezxenstore/watch/dune b/ocaml/libs/ezxenstore/watch/dune index 17e081a37ee..dfd2f3020cb 100644 --- a/ocaml/libs/ezxenstore/watch/dune +++ b/ocaml/libs/ezxenstore/watch/dune @@ -4,5 +4,8 @@ (wrapped false) (libraries ezxenstore_core - xenctrl) + xenctrl + uuidm + threads.posix + ) ) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index dfc10dccb15..dae6e86e669 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -8,6 +8,7 @@ (libraries astring base64 + fmt ipaddr mtime mtime.clock.os @@ -35,10 +36,12 @@ (library (name httpsvr) (wrapped false) + (modes best) (modules http_svr http_proxy server_io) (libraries astring http_lib + ipaddr polly threads.posix xapi-log @@ -51,10 +54,12 @@ (tests (names http_test radix_tree_test) (package http-lib) + (modes (best exe)) (modules http_test radix_tree_test) (libraries alcotest dune-build-info + fmt http_lib ) ) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 6c18e2f15c1..434239cc24e 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -1,7 +1,7 @@ (library (name tracing) (modules tracing) - (libraries re uri xapi-log xapi-stdext-threads) + (libraries re uri xapi-log xapi-stdext-threads threads.posix) (public_name xapi-tracing)) (library @@ -15,7 +15,10 @@ ptime.clock.os rpclib.core rpclib.json + result + rresult tracing + threads.posix uri xapi-log xapi-open-uri diff --git a/ocaml/libs/uuid/dune b/ocaml/libs/uuid/dune index d9266c021f8..5f7c5c25b95 100644 --- a/ocaml/libs/uuid/dune +++ b/ocaml/libs/uuid/dune @@ -3,7 +3,7 @@ (public_name uuid) (modules uuidx) (libraries - unix uuidm + unix (re_export uuidm) ) (wrapped false) ) diff --git a/ocaml/libs/vhd/cli/dune b/ocaml/libs/vhd/cli/dune index 303f72e0d91..f871b3d2f8c 100644 --- a/ocaml/libs/vhd/cli/dune +++ b/ocaml/libs/vhd/cli/dune @@ -2,4 +2,4 @@ (name disk_to_ocaml) (public_name disk_to_ocaml) (package vhd-format-lwt) - (libraries disk lwt)) + (libraries disk lwt lwt.unix)) diff --git a/ocaml/libs/vhd/vhd_format/dune b/ocaml/libs/vhd/vhd_format/dune index f2fd63b464f..5478cb41a48 100644 --- a/ocaml/libs/vhd/vhd_format/dune +++ b/ocaml/libs/vhd/vhd_format/dune @@ -2,5 +2,5 @@ (name vhd_format) (public_name vhd-format) (flags :standard -w -32-34-37) - (libraries stdlib-shims cstruct io-page rresult uuidm) + (libraries stdlib-shims (re_export bigarray-compat) cstruct io-page rresult uuidm) (preprocess (pps ppx_cstruct))) diff --git a/ocaml/libs/vhd/vhd_format_lwt/dune b/ocaml/libs/vhd/vhd_format_lwt/dune index 9faf463f409..06f37079439 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/dune +++ b/ocaml/libs/vhd/vhd_format_lwt/dune @@ -1,7 +1,7 @@ (library (name vhd_format_lwt) (public_name vhd-format-lwt) - (libraries cstruct lwt lwt.unix mirage-block vhd-format) + (libraries bigarray-compat cstruct-lwt cstruct lwt lwt.unix mirage-block vhd-format rresult) (foreign_stubs (language c) (names blkgetsize64_stubs lseek64_stubs odirect_stubs))) diff --git a/ocaml/libs/xapi-inventory/lib/dune b/ocaml/libs/xapi-inventory/lib/dune index 7fb4aa7e40b..905b47bfceb 100644 --- a/ocaml/libs/xapi-inventory/lib/dune +++ b/ocaml/libs/xapi-inventory/lib/dune @@ -7,6 +7,6 @@ astring xapi-stdext-unix xapi-stdext-threads - threads + threads.posix ) ) diff --git a/ocaml/libs/xapi-rrd/lib/dune b/ocaml/libs/xapi-rrd/lib/dune index 00b4bedfc3d..2f90e3e2f45 100644 --- a/ocaml/libs/xapi-rrd/lib/dune +++ b/ocaml/libs/xapi-rrd/lib/dune @@ -6,6 +6,7 @@ (libraries bigarray rpclib.json + rpclib.core xmlm yojson ) diff --git a/ocaml/libs/xapi-rrd/lib_test/dune b/ocaml/libs/xapi-rrd/lib_test/dune index b565d445d49..7a66380a63e 100644 --- a/ocaml/libs/xapi-rrd/lib_test/dune +++ b/ocaml/libs/xapi-rrd/lib_test/dune @@ -9,6 +9,8 @@ unix xapi-rrd xapi-stdext-unix + rpclib.xml + xmlm ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune new file mode 100644 index 00000000000..4ae4d8d51b2 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml new file mode 100644 index 00000000000..b3d28b15c4d --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml @@ -0,0 +1,138 @@ +(* + * 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 total_delays = Gen.oneofa [|0.001; 0.01; 0.1; 0.4|] + +let span_of_s s = s *. 1e9 |> Mtime.Span.of_float_ns |> Option.get + +(* keep these short *) +let timeouts = Gen.oneofa [|0.0; 0.001; 0.1; 0.3|] + +let delay_of_size total_delay size = + let open Gen in + let* every_bytes = if size = 0 then return 1 else 1 -- size in + let chunks = max 1 (size / every_bytes) in + let duration = total_delay /. float_of_int chunks |> span_of_s in + return @@ Some (Delay.v ~every_bytes ~duration) + +let t = + let open Gen in + (* order matters here for shrinking: shrink timeout first so that shrinking completes sooner! *) + let* total_delay = total_delays and* size = sizes and* kind = fst file_kind in + let* delay = delay_of_size total_delay size in + return @@ make ~delay_read:delay ~delay_write:delay ~size kind + +let print t = + (* to easily grep print on single line *) + let buf = Buffer.create 128 in + let fmt = Fmt.with_buffer buf in + Format.pp_set_geometry fmt ~max_indent:999 ~margin:1000 ; + Fmt.( + record ~sep:(any "; ") + [ + 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 + ] + ) + fmt t ; + Fmt.flush fmt () ; + Buffer.contents buf + +let run_ro t data ~f = + (* 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 = + 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 ~size:t.size + +let run_rw t data ~f = + 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 + let write = + match t.delay_write with + | Some delay -> + Delay.apply_write cancel delay single_write_substring + | None -> + single_write_substring + in + observe_rw read write ~f t.kind ~size:t.size data diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli new file mode 100644 index 00000000000..6aba67c7a6d --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli @@ -0,0 +1,87 @@ +(* + * 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 +*) + +val run_rw : + t + -> string + -> f:((rdwr, kind) make -> 'a) + -> ([> rdonly] observation option, [> wronly] observation option) observations + * 'a or_exn +(** [run_rw t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as read-write. + + @returns observations about [f]'s actions the file descriptor +*) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml new file mode 100644 index 00000000000..32213b6de98 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml @@ -0,0 +1,307 @@ +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 truncated_string ppf s = + let n = 35 in + if String.length s < 2 * n then + Fmt.string ppf s + else + Fmt.pf ppf "%S...%S" (String.sub s 0 n) + (String.sub s (String.length s - n) n) + +let pp ppf = + Fmt.( + record ~sep:(any ";") + [ + field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ; field "data" (fun t -> t.data) truncated_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 ~sep:(any ";") + [ + 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 ~size = + let length = size 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 + let result = (Mtime_clock.count dt, r) in + close arg ; result + +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 -> + let r = do_write write written expected off (as_writable_opt fd) in + close fd ; r + ) + 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 ~size 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 ~size 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) + +let observe_rw read write ~f ~size kind expected = + with_kind_rw kind @@ fun rw1 rw2 -> + let written = Buffer.create 0 in + let rd_buf = Buffer.create 0 in + let gw fd = do_write write written expected 0 (as_writable_opt fd) + and gr fd = do_read ~size read rd_buf (as_readable_opt fd) in + let g fd = + let r = concurrently (gr, gw) (fd, fd) in + close fd ; r + in + let res, thread_result = concurrently (wrap_measure f, g) (rw1, rw2) in + let elapsed, res = unwrap_exn res in + let read, write = unwrap_exn thread_result in + let read = + read + |> unwrap_exn + |> Option.map @@ fun read -> {read with data= Buffer.contents rd_buf} + and write = + write + |> unwrap_exn + |> Option.map @@ fun write -> {write with data= Buffer.contents written} + in + ({read; write; elapsed}, res) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli new file mode 100644 index 00000000000..2e4ecb6b7d0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli @@ -0,0 +1,202 @@ +(* + * 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) + -> size:int + -> Unix.file_kind + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [observe_wo read ~f ~size 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. + It expects [size] bytes written by [f]. + + @returns an observation of [f]'s actions on the file descriptor and [f]'s result + *) + +val observe_rw : + (([> readable], kind) Properties.t, bytes) operation + -> (([> writable], kind) Properties.t, string) operation + -> f:((rdwr, kind) make -> 'a) + -> size:int + -> Unix.file_kind + -> string + -> ([> rdonly] observation option, [> wronly] observation option) observations + * 'a or_exn +(** [observe_rw read write ~f ~size 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 read the operation used for reading, allows insertion of delays + @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 + *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune new file mode 100644 index 00000000000..ecc23b141b3 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml new file mode 100644 index 00000000000..b6ae12eb035 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml @@ -0,0 +1,115 @@ +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 ~size:128 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/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune new file mode 100644 index 00000000000..cb3c54ea189 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml new file mode 100644 index 00000000000..bce25cdcd03 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli new file mode 100644 index 00000000000..6097f8cddf5 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml new file mode 100644 index 00000000000..d26194cfeb9 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli new file mode 100644 index 00000000000..6b51a3ab7a7 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml new file mode 100644 index 00000000000..1d0d3a92b6d --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli new file mode 100644 index 00000000000..710d1a5ee47 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune new file mode 100644 index 00000000000..505852753bb --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t new file mode 100644 index 00000000000..51b37e0eaeb --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml new file mode 100644 index 00000000000..fa60e5f6682 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml new file mode 100644 index 00000000000..e72e179af51 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml new file mode 100644 index 00000000000..ea1b1343410 --- /dev/null +++ b/ocaml/libs/xapi-stdext/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/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index fe2cc6dd85a..4db49ea52e2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -1,8 +1,15 @@ (library (public_name xapi-stdext-threads) (name xapi_stdext_threads) + (modules :standard \ threadext_test) (libraries threads.posix unix + xapi-stdext-unix xapi-stdext-pervasives) ) +(test + (name threadext_test) + (modules threadext_test) + (libraries xapi_stdext_threads alcotest mtime.clock.os mtime fmt) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index 56025d51154..ef30cfb5ba4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -86,11 +86,15 @@ module Delay = struct pipe_out ) in - let r, _, _ = Unix.select [pipe_out] [] [] seconds in + let open Xapi_stdext_unix.Unixext in (* flush the single byte from the pipe *) - if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; + try + let (_ : string) = + time_limited_single_read pipe_out 1 ~max_wait:seconds + in + false + with Timeout -> true (* return true if we waited the full length of time, false if we were woken *) - r = [] with Pre_signalled -> false ) (fun () -> diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml new file mode 100644 index 00000000000..c21cd62e8c0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * 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. + *) + +module Delay = Xapi_stdext_threads.Threadext.Delay + +let span_approx ~max_error = + let eq_within a b = + let diff = Mtime.Span.abs_diff a b in + Mtime.Span.compare diff max_error < 0 + in + Alcotest.testable Mtime.Span.pp @@ eq_within + +let test_wait () = + let m = Delay.make () in + let c = Mtime_clock.counter () in + let time = 1 in + let expected = Mtime.Span.(time * s) in + let max_error = Mtime.Span.(10 * ms) in + let _ = Delay.wait m (float_of_int time) in + let wait_time = Mtime_clock.count c in + Alcotest.check' (span_approx ~max_error) ~msg:"diff is smaller than max error" + ~expected ~actual:wait_time + +let () = Alcotest.run "Threadext" [("wait", [("wait", `Quick, test_wait)])] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune index da0b509d2d2..de736b3fdd2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune @@ -3,8 +3,10 @@ (public_name xapi-stdext-unix) (libraries fd-send-recv + polly unix xapi-backtrace + threads.posix xapi-stdext-pervasives) (foreign_stubs (language c) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune new file mode 100644 index 00000000000..7c86c6371d4 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -0,0 +1,13 @@ +(test + (name unixext_test) + (modules unixext_test) + (libraries xapi_stdext_unix qcheck-core mtime.clock.os qcheck-core.runner fmt xapi_fd_test mtime threads.posix rresult) + ; use fixed seed to avoid causing random failures in CI and package builds + (action (run %{test} -v -bt --seed 42)) +) + +(rule + (alias stresstest) + ; use default random seed on stresstests + (action (run %{dep:unixext_test.exe} -v -bt)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/generate.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml new file mode 100644 index 00000000000..2acad9396fd --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -0,0 +1,195 @@ +open QCheck2 +open Xapi_stdext_unix +open Xapi_fd_test + +let expect_string ~expected ~actual = + if not (String.equal expected actual) then + Test.fail_reportf "Data sent and observed do not match: %S <> %S" expected + actual + +let expect_amount ~expected observation = + let open Observations in + let actual = String.length observation.data in + if expected <> actual then + Test.fail_reportf + "Amount of data available and transferred does not match: %d <> %d;@,%a" + expected actual pp observation + +let skip_blk = function + | Unix.S_BLK -> + if Unix.geteuid () <> 0 then + QCheck2.assume_fail () + | _ -> + () + +let skip_dirlnk = function + | Unix.S_DIR | Unix.S_LNK -> + QCheck2.assume_fail () + | _ -> + () + +(* +let pp_pair = + let open Observations in + Fmt.(record + [ field "read" (fun t -> t.read) pp + ; field "write" (fun t -> t.write) pp + ; field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ] + ) +*) + +let test_time_limited_write = + let gen = Gen.tup2 Generate.t Generate.timeouts + and print = Print.tup2 Generate.print Print.float in + Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> + skip_blk behaviour.kind ; + skip_dirlnk behaviour.kind ; + try + let test_elapsed = ref Mtime.Span.zero in + let test wrapped_fd = + let len = behaviour.size in + let buf = String.init len (fun i -> Char.chr (i mod 255)) in + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + Unix.set_nonblock fd ; + let dt = Mtime_clock.counter () in + let deadline = Unix.gettimeofday () +. timeout in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Unixext.time_limited_write_substring fd len buf deadline + ) ; + buf + in + (*Printf.eprintf "testing write: %s\n%!" (print (behaviour, timeout)) ;*) + let observations, result = Generate.run_wo behaviour ~f:test in + let () = + let open Observations in + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s > timeout +. 0.5 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %f > %f; %s" + elapsed_s timeout + (Fmt.to_to_string Fmt.(option pp) observations.Observations.read) ; + match (observations, result) with + | {read= Some read; _}, Ok expected -> + (* expected is the input given to [time_limited_write_substring] *) + expect_amount ~expected:(String.length expected) read ; + expect_string ~expected ~actual:read.data + | {read= Some read; _}, Error (`Exn_trap (Unixext.Timeout, _)) -> + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s < timeout then + Test.fail_reportf "Timed out earlier than requested: %f < %f" + elapsed_s timeout ; + let actual = String.length read.data in + if actual >= behaviour.size then + Test.fail_reportf "Timed out, but transferred enough data: %d >= %d" + actual behaviour.size + | ( {read= Some read; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length read.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {read= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + with e -> + Format.eprintf "Error: %a@." Fmt.exn_backtrace + (e, Printexc.get_raw_backtrace ()) ; + false + +let test_time_limited_read = + let gen = Gen.tup2 Generate.t Generate.timeouts + and print = Print.tup2 Generate.print Print.float in + Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> + (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) + skip_blk behaviour.kind ; + skip_dirlnk behaviour.kind ; + let test_elapsed = ref Mtime.Span.zero in + let test wrapped_fd = + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + Unix.set_nonblock fd ; + let dt = Mtime_clock.counter () in + let deadline = Unix.gettimeofday () +. timeout in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Unixext.time_limited_read fd behaviour.size deadline + ) + in + (*Printf.eprintf "testing: %s\n%!" (print (behaviour, timeout)) ;*) + let observations, result = + let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in + Generate.run_ro behaviour buf ~f:test + in + let () = + let open Observations in + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s > timeout +. 0.5 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %f > %f; %s" elapsed_s + timeout + (Fmt.to_to_string Fmt.(option pp) observations.Observations.write) ; + (* Format.eprintf "Result: %a@." (Fmt.option Observations.pp) observations.write;*) + match (observations, result) with + | {write= Some write; _}, Ok actual -> + expect_amount ~expected:(String.length actual) write ; + expect_string ~expected:write.data ~actual + | {write= Some _; _}, Error (`Exn_trap (Unixext.Timeout, _)) -> + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s < timeout then + Test.fail_reportf "Timed out earlier than requested: %f < %f" + elapsed_s timeout + | ( {write= Some write; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length write.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {write= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + +let test_proxy = + let gen = Generate.t and print = Generate.print in + Test.make ~name:__FUNCTION__ ~print gen @@ fun behaviour -> + if behaviour.kind <> Unix.S_SOCK then + QCheck2.assume_fail () ; + let test wrapped_fd = + let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + let test2 wrapped_fd2 = + let fd2 = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd2 in + Unixext.proxy (Unix.dup fd) (Unix.dup fd2) + in + match Generate.run_rw behaviour buf ~f:test2 with + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + | obs, Ok () -> + obs + in + let buf' = + String.init behaviour.size (fun i -> Char.chr ((30 + i) mod 255)) + in + match Generate.run_rw behaviour buf' ~f:test with + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + | {read= None; _}, Ok _ -> + false + | _, Ok {write= None; _} -> + false + | {read= Some write; _}, Ok {write= Some read; _} -> + expect_string ~expected:write.data ~actual:read.data ; + true + +let tests = [test_proxy; test_time_limited_write; test_time_limited_read] + +let () = + (* avoid SIGPIPE *) + let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in + QCheck_base_runner.run_tests_main tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 4cf628d45e9..160cfe46b67 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -383,7 +383,7 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = let cmdline = readcmdline pid in if cmdline = reference then ( (* still up, let's sleep a bit *) - ignore (Unix.select [] [] [] loop_time_waiting) ; + Thread.delay loop_time_waiting ; left := !left -. loop_time_waiting ) else (* not the same, it's gone ! *) quit := true @@ -422,6 +422,11 @@ let string_of_signal x = else Printf.sprintf "(ocaml signal %d with an unknown name)" x +let with_polly f = + let polly = Polly.create () in + let finally () = Polly.close polly in + Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> f polly) finally + let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let size = 64 * 1024 in (* [a'] is read from [a] and will be written to [b] *) @@ -429,24 +434,38 @@ let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let a' = CBuf.empty size and b' = CBuf.empty size in Unix.set_nonblock a ; Unix.set_nonblock b ; + with_polly @@ fun polly -> + Polly.add polly a Polly.Events.empty ; + Polly.add polly b Polly.Events.empty ; try while true do - let r = - (if CBuf.should_read a' then [a] else []) - @ if CBuf.should_read b' then [b] else [] - in - let w = - (if CBuf.should_write a' then [b] else []) - @ if CBuf.should_write b' then [a] else [] + (* use oneshot notification so that we can use Polly.mod as needed to reenable, + but it will disable itself each turn *) + let a_events = + Polly.Events.( + (if CBuf.should_read a' then inp lor oneshot else empty) + lor if CBuf.should_write b' then out lor oneshot else empty + ) + and b_events = + Polly.Events.( + (if CBuf.should_read b' then inp lor oneshot else empty) + lor if CBuf.should_write a' then out lor oneshot else empty + ) in (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file ; - let r, w, _ = Unix.select r w [] (-1.0) in - (* Do the writing before the reading *) - List.iter - (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) - w ; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; + if Polly.Events.(a_events lor b_events = empty) then raise End_of_file ; + + if Polly.Events.(a_events <> empty) then + Polly.upd polly a a_events ; + if Polly.Events.(b_events <> empty) then + Polly.upd polly b b_events ; + Polly.wait_fold polly 4 (-1) () (fun _polly fd events () -> + (* Do the writing before the reading *) + if Polly.Events.(test out events) then + if a = fd then CBuf.write b' a else CBuf.write a' b ; + if Polly.Events.(test inp events) then + if a = fd then CBuf.read a' a else CBuf.read b' b + ) ; (* If there's nothing else to read or write then signal the other end *) List.iter (fun (buf, fd) -> @@ -528,32 +547,69 @@ let really_read_string fd length = exception Timeout +let to_milliseconds ms = ms *. 1000. |> ceil |> int_of_float + +(* Allocating a new polly and waiting like this results in at least 3 syscalls. + An alternative for sockets would be to use [setsockopt], + but that would need 3 system calls too: + + [fstat] to check that it is not a pipe + (you'd risk getting stuck forever without [select/poll/epoll] there) + [setsockopt_float] to set the timeout + [clear_nonblock] to ensure the socket is non-blocking +*) +let with_polly_wait kind fd f = + match Unix.(LargeFile.fstat fd).st_kind with + | S_DIR -> + failwith "File descriptor cannot be a directory for read/write" + | S_LNK -> + (* should never happen, the file is already open and OCaml doesn't support O_SYMLINK to open the link itself *) + failwith "cannot read/write into a symbolic link" + | S_REG | S_BLK -> + (* the best we can do is to split up the read/write operation into 64KiB chunks, + and check the timeout after each chunk. + select() would've silently succeeded here, whereas epoll() is stricted and returns EPERM + *) + let wait remaining_time = if remaining_time < 0. then raise Timeout in + f wait fd + | S_CHR | S_FIFO | S_SOCK -> + with_polly @@ fun polly -> + Polly.add polly fd kind ; + let wait remaining_time = + let milliseconds = to_milliseconds remaining_time in + if milliseconds <= 0 then raise Timeout ; + let ready = + Polly.wait polly 1 milliseconds @@ fun _ event_on_fd _ -> + assert (event_on_fd = fd) + in + if ready = 0 then raise Timeout + in + f wait fd + (* Write as many bytes to a file descriptor as possible from data before a given clock time. *) (* Raises Timeout exception if the number of bytes written is less than the specified length. *) (* Writes into the file descriptor at the current cursor position. *) let time_limited_write_internal (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data target_response_time = + with_polly_wait Polly.Events.out filedesc @@ fun wait filedesc -> let total_bytes_to_write = length in let bytes_written = ref 0 in let now = ref (Unix.gettimeofday ()) in while !bytes_written < total_bytes_to_write && !now < target_response_time do let remaining_time = target_response_time -. !now in - let _, ready_to_write, _ = Unix.select [] [filedesc] [] remaining_time in - (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) - ( if List.mem filedesc ready_to_write then - let bytes_to_write = total_bytes_to_write - !bytes_written in - let bytes = - try write filedesc data !bytes_written bytes_to_write - with - | Unix.Unix_error (Unix.EAGAIN, _, _) - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) - -> - 0 - in - (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) - bytes_written := bytes + !bytes_written - ) ; + wait remaining_time ; + let bytes_to_write = total_bytes_to_write - !bytes_written in + let bytes = + try write filedesc data !bytes_written bytes_to_write + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + bytes_written := bytes + !bytes_written ; now := Unix.gettimeofday () done ; if !bytes_written = total_bytes_to_write then @@ -562,40 +618,39 @@ let time_limited_write_internal raise Timeout let time_limited_write filedesc length data target_response_time = - time_limited_write_internal Unix.write filedesc length data + time_limited_write_internal Unix.single_write filedesc length data target_response_time let time_limited_write_substring filedesc length data target_response_time = - time_limited_write_internal Unix.write_substring filedesc length data + time_limited_write_internal Unix.single_write_substring filedesc length data target_response_time (* Read as many bytes to a file descriptor as possible before a given clock time. *) (* Raises Timeout exception if the number of bytes read is less than the desired number. *) (* Reads from the file descriptor at the current cursor position. *) let time_limited_read filedesc length target_response_time = + with_polly_wait Polly.Events.inp filedesc @@ fun wait filedesc -> let total_bytes_to_read = length in let bytes_read = ref 0 in let buf = Bytes.make total_bytes_to_read '\000' in let now = ref (Unix.gettimeofday ()) in while !bytes_read < total_bytes_to_read && !now < target_response_time do let remaining_time = target_response_time -. !now in - let ready_to_read, _, _ = Unix.select [filedesc] [] [] remaining_time in - ( if List.mem filedesc ready_to_read then - let bytes_to_read = total_bytes_to_read - !bytes_read in - let bytes = - try Unix.read filedesc buf !bytes_read bytes_to_read - with - | Unix.Unix_error (Unix.EAGAIN, _, _) - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) - -> - 0 - in - (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) - if bytes = 0 then - raise End_of_file (* End of file has been reached *) - else - bytes_read := bytes + !bytes_read - ) ; + wait remaining_time ; + let bytes_to_read = total_bytes_to_read - !bytes_read in + let bytes = + try Unix.read filedesc buf !bytes_read bytes_to_read + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) + if bytes = 0 then + raise End_of_file (* End of file has been reached *) + else + bytes_read := bytes + !bytes_read ; now := Unix.gettimeofday () done ; if !bytes_read = total_bytes_to_read then @@ -603,6 +658,20 @@ let time_limited_read filedesc length target_response_time = else (* we ran out of time *) raise Timeout +let time_limited_single_read filedesc length ~max_wait = + let buf = Bytes.make length '\000' in + with_polly_wait Polly.Events.inp filedesc @@ fun wait filedesc -> + wait max_wait ; + let bytes = + try Unix.read filedesc buf 0 length + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + Bytes.sub_string buf 0 bytes + (* --------------------------------------------------------------------------------------- *) (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index c6168150b54..df81171a3b4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -153,6 +153,9 @@ val time_limited_write_substring : val time_limited_read : Unix.file_descr -> int -> float -> string +val time_limited_single_read : + Unix.file_descr -> int -> max_wait:float -> string + val read_data_in_string_chunks : (string -> int -> unit) -> ?block_size:int diff --git a/ocaml/message-switch/async/dune b/ocaml/message-switch/async/dune index a0a1beb8c19..89f2c3a5ff4 100644 --- a/ocaml/message-switch/async/dune +++ b/ocaml/message-switch/async/dune @@ -2,14 +2,15 @@ (name message_switch_async) (public_name message-switch-async) (libraries - async - async_unix + (re_export async) + (re_export async_unix) async_kernel base cohttp-async - core + (re_export core) core_unix core_kernel + core_unix.time_unix message-switch-core ) ) diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune index 6debbc895c7..41cbf9e9f2d 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -8,6 +8,7 @@ rpclib.json sexplib sexplib0 + threads.posix uri xapi-log xapi-stdext-threads diff --git a/ocaml/message-switch/core_test/async/dune b/ocaml/message-switch/core_test/async/dune index 2891908317e..6e690c35e1d 100644 --- a/ocaml/message-switch/core_test/async/dune +++ b/ocaml/message-switch/core_test/async/dune @@ -13,6 +13,8 @@ cohttp-async core core_kernel + core_unix + core_unix.time_unix message-switch-async ) ) diff --git a/ocaml/message-switch/lwt/dune b/ocaml/message-switch/lwt/dune index 2aaf432952b..12f03301298 100644 --- a/ocaml/message-switch/lwt/dune +++ b/ocaml/message-switch/lwt/dune @@ -4,8 +4,8 @@ (libraries cohttp-lwt-unix message-switch-core - lwt - lwt.unix + (re_export lwt) + (re_export lwt.unix) ) ) diff --git a/ocaml/squeezed/src/dune b/ocaml/squeezed/src/dune index cbdf62e39c8..c5d6683ad92 100644 --- a/ocaml/squeezed/src/dune +++ b/ocaml/squeezed/src/dune @@ -8,6 +8,7 @@ xapi-stdext-threads xapi-stdext-pervasives xapi-stdext-unix + xapi_version astring dune-build-info rpclib.core diff --git a/ocaml/tests/alerts/dune b/ocaml/tests/alerts/dune index 3e932d190f3..613f4077eaa 100644 --- a/ocaml/tests/alerts/dune +++ b/ocaml/tests/alerts/dune @@ -6,11 +6,13 @@ certificate_check daily_license_check dune-build-info + expiry_alert fmt xapi-consts xapi-log xapi-stdext-date xapi-types + uuid ) (action (run %{test} --color=always)) ) diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index fdc6fbd9a6c..c578f5f9785 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -1,6 +1,7 @@ (library (name tests_common) (modules :standard) + (modes best) (wrapped false) (libraries alcotest diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 93bf4b66ddf..c6c7caed7e7 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -1,6 +1,6 @@ (test (name suite_alcotest) - (modes exe) + (modes (best exe)) (package xapi) (modules (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering @@ -17,6 +17,7 @@ dune-build-info fmt http_lib + httpsvr ipaddr mirage-crypto pam @@ -70,6 +71,7 @@ (libraries alcotest fmt + ptime result rpclib.core rpclib.json @@ -90,7 +92,9 @@ xapi-test-utils xapi-tracing xapi-types + xapi-stdext-date xapi-stdext-threads + xapi-stdext-unix xml-light2 yojson ) @@ -101,27 +105,34 @@ (modes exe) (package xapi) (modules test_storage_smapiv1_wrapper) -(libraries alcotest xapi_internal fmt)) +(libraries alcotest xapi_internal fmt xapi-idl.storage.interface xapi-idl.storage.interface.types)) (test (name test_storage_quicktest) (modes exe) (package xapi) (modules test_storage_quicktest) -(libraries xapi_internal crowbar)) +(libraries xapi_internal crowbar xapi-idl.storage.interface.types)) (test (name test_ref) (modes exe) (package xapi) (modules test_ref) -(libraries xapi_internal crowbar)) +(libraries + crowbar + fmt + uuidm + xapi-types + xapi_internal +)) (test (name test_observer) (package xapi) +(modes (best exe)) (modules test_observer) -(libraries alcotest tracing xapi_internal tests_common yojson)) +(libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std xapi-tracing.export)) (rule (alias runtest) diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index 6814d74fd56..b81c0c2e607 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -12,6 +12,7 @@ rresult sexplib sexplib0 + uri tar threads.posix xapi-backtrace diff --git a/ocaml/xapi-client/dune b/ocaml/xapi-client/dune index 9951eb6cfbc..d85c2af74af 100644 --- a/ocaml/xapi-client/dune +++ b/ocaml/xapi-client/dune @@ -15,7 +15,7 @@ (libraries mtime mtime.clock.os - rpclib.core + (re_export rpclib.core) xapi-consts xapi-log xapi-types diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index 052810ead5f..dd35baf40cb 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -6,13 +6,22 @@ cohttp-lwt cohttp-lwt-unix conduit-lwt-unix + fmt + log lwt lwt.unix + mtime + mtime.clock + mtime.clock.os result rpclib.core rpclib-lwt + rpclib.xml + uuidm + uri xapi_guard xapi-idl.xen.interface + xapi-idl.guard.varstored xapi-log xapi-types xen-api-client-lwt @@ -23,10 +32,18 @@ (modules dorpc types disk_cache lwt_bounded_stream) (libraries rpclib.core + fmt inotify inotify.lwt + rresult + result + log lwt lwt.unix + mtime + mtime.clock + mtime.clock.os + uuidm uri xapi-backtrace xapi-consts diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index baac1d24101..ac7a6665c1a 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -20,6 +20,7 @@ xapi-idl.guard.privileged xapi-log xapi-types + xapi_version xen-api-client-lwt) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-guard/test/dune b/ocaml/xapi-guard/test/dune index e082a47a690..9d44fdefbac 100644 --- a/ocaml/xapi-guard/test/dune +++ b/ocaml/xapi-guard/test/dune @@ -15,6 +15,7 @@ xapi_guard_server xapi-log xapi-types + xapi_version xen-api-client-lwt) (package varstored-guard) ) @@ -23,6 +24,7 @@ (name cache_test) (modules cache_test) (libraries + fmt logs logs.fmt logs.lwt @@ -30,6 +32,8 @@ lwt.unix mtime mtime.clock.os + result uuidm + xapi-log xapi_guard) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-idl/guard/varstored/dune b/ocaml/xapi-idl/guard/varstored/dune index 0e6bd85b627..a54af22988a 100644 --- a/ocaml/xapi-idl/guard/varstored/dune +++ b/ocaml/xapi-idl/guard/varstored/dune @@ -3,7 +3,7 @@ (public_name xapi-idl.guard.varstored) (modules (:standard \ varstored_cli)) (libraries - rpclib.core + (re_export rpclib.core) threads xapi-idl.xen xapi-idl.xen.interface diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index 91c72783c42..c8feec1ff1a 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -51,6 +51,7 @@ rpclib.json sexplib sexplib0 + tracing threads.posix xapi-backtrace xapi-idl diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index de6906fdfcd..57c8c95e592 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -2,7 +2,7 @@ (name test_lib) (modules idl_test_common) (libraries - alcotest xapi-idl) + (re_export alcotest) xapi-idl (re_export rpclib.core) rpclib.json rpclib.xml result) (wrapped false) ) @@ -26,6 +26,7 @@ (deps (source_tree test_data)) (libraries alcotest + cohttp_posix fmt result rpclib.core @@ -34,6 +35,7 @@ rpclib.xml test_lib threads.posix + xapi-idl xapi-idl.cluster xapi-idl.rrd xapi-idl.memory diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index f1c02f5c837..b7d62f7e32a 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -10,7 +10,6 @@ core core_unix core_unix.time_unix - core_kernel dune-build-info message-switch-async message-switch-unix diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index fe161e0dd5f..1c92b8e6017 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -57,6 +57,7 @@ (library (name xapi_internal) (wrapped false) + (modes best) (modules (:standard \ xapi_main)) (libraries angstrom @@ -64,6 +65,7 @@ cstruct base64 cohttp + cohttp_posix domain-name ezxenstore.core fmt @@ -72,6 +74,7 @@ gzip hex http_lib + httpsvr ipaddr magic-mime message-switch-core @@ -84,6 +87,7 @@ pciutil pci ptime + ptime.clock.os rpclib.core rpclib.json rpclib.xml @@ -110,7 +114,7 @@ x509 xapi_aux xapi-backtrace - xapi-consts + (re_export xapi-consts) xapi-consts.xapi_version xapi-client xapi-cli-protocol @@ -137,7 +141,7 @@ xapi-log xapi-open-uri xapi-rrd - xapi-types + (re_export xapi-types) xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives @@ -146,6 +150,7 @@ xapi-stdext-unix xapi-stdext-zerocheck xapi-tracing + xapi-tracing.export xapi-xenopsd xenstore_transport.unix xml-light2 diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 42b0823d9c2..1dbab9c0ea6 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -31,6 +31,7 @@ xapi-stdext-threads xapi-stdext-unix xmlm + yojson ) (preprocess (pps ppx_deriving_rpc)) ) @@ -48,6 +49,7 @@ ezxenstore.watch forkexec http_lib + httpsvr inotify rpclib.core rpclib.json diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune index 4ff5ab43453..4c6dd005206 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune @@ -20,6 +20,7 @@ xapi-idl.rrd xapi-log xapi-rrd + xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index dede643723b..7d0429650d6 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -10,6 +10,7 @@ safe-resources stunnel threads + yojson xapi-backtrace xapi-cli-protocol xapi-stdext-pervasives diff --git a/ocaml/xen-api-client/async/dune b/ocaml/xen-api-client/async/dune index 406f2cc8cf9..a3ed8b645b7 100644 --- a/ocaml/xen-api-client/async/dune +++ b/ocaml/xen-api-client/async/dune @@ -8,6 +8,8 @@ base cohttp core + core_unix + core_unix.time_unix core_kernel rpclib.core rpclib.json diff --git a/ocaml/xenopsd/dbgring/dune b/ocaml/xenopsd/dbgring/dune index 7fa6db8c16d..0f79c13e2f0 100644 --- a/ocaml/xenopsd/dbgring/dune +++ b/ocaml/xenopsd/dbgring/dune @@ -6,6 +6,7 @@ dune-build-info xapi-xenopsd xenctrl + xenmmap xenstore xenstore.unix xenstore_transport diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index 0521c4b3db4..c76d5c7d6a9 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -6,6 +6,7 @@ astring c_stubs cohttp + cohttp_posix fd-send-recv fmt forkexec diff --git a/ocaml/xenopsd/pvs/dune b/ocaml/xenopsd/pvs/dune index 6b915db2255..d8b113392c9 100644 --- a/ocaml/xenopsd/pvs/dune +++ b/ocaml/xenopsd/pvs/dune @@ -2,6 +2,6 @@ (name pvs_proxy_setup) (public_name pvs-proxy-ovs-setup) (package xapi-xenopsd-xc) - (libraries ezxenstore.core bos xapi-consts.xapi_version xapi-idl cmdliner) + (libraries ezxenstore.core bos xapi-consts.xapi_version xapi-idl cmdliner log rresult) ) diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 032d99d16c0..7fedcaa3207 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -27,6 +27,7 @@ sexplib0 qmp threads.posix + uri uuid uuidm xapi-backtrace diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index b168c190faa..d21ef4bf68e 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -4,7 +4,10 @@ (public_name xs-trace) (package xapi) (libraries + uri + tracing tracing_export xapi-stdext-unix + zstd ) ) diff --git a/ocaml/xxhash/lib/dune b/ocaml/xxhash/lib/dune index 1923c3d6510..70b43c59192 100644 --- a/ocaml/xxhash/lib/dune +++ b/ocaml/xxhash/lib/dune @@ -15,6 +15,7 @@ (wrapped false) (libraries ctypes + ctypes.stubs integers xxhash_bindings xapi-stdext-pervasives diff --git a/xapi-fd-test.opam b/xapi-fd-test.opam new file mode 100644 index 00000000000..d6887267659 --- /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: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/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/xen-api.git" diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam new file mode 100644 index 00000000000..c4428d7e0bc --- /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: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/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/xen-api.git" diff --git a/xapi-rrd-transport.opam b/xapi-rrd-transport.opam index e9882d24b12..7cdb8205c98 100644 --- a/xapi-rrd-transport.opam +++ b/xapi-rrd-transport.opam @@ -1,7 +1,7 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-rrdd-plugin.opam b/xapi-rrdd-plugin.opam index 68a9ed509c5..b01d85a6da5 100644 --- a/xapi-rrdd-plugin.opam +++ b/xapi-rrdd-plugin.opam @@ -1,7 +1,7 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index a7f4951d856..393ad6ef128 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.12"} "alcotest" {with-test} "astring" @@ -16,7 +16,7 @@ depends: [ "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index c3538116761..a01829f99ac 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.13.0"} "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} @@ -16,7 +16,7 @@ depends: [ "notty" {with-test} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 53fd4b34939..b0309093fa5 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -7,14 +7,14 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.08"} "logs" "odoc" {with-doc} "xapi-backtrace" ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 95b61c73e3e..e4f40a8ae6a 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -7,13 +7,13 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.08.0"} "alcotest" {with-test} "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 9dcc9ff090c..8de2f45c03e 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -7,15 +7,17 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" "base-threads" "base-unix" "odoc" {with-doc} "xapi-stdext-pervasives" {= version} + "mtime" {with-test} + "xapi-stdext-unix" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index f8e709afe7f..36df8e943d8 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -7,16 +7,17 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.12.0"} "base-unix" "fd-send-recv" {>= "2.0.0"} "odoc" {with-doc} "xapi-backtrace" "xapi-stdext-pervasives" {= version} + "polly" ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" @@ -31,4 +32,4 @@ build: [ ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" depexts: ["linux-headers"] {os-distribution = "alpine"} -available: [ os = "macos" | os = "linux" ] +available: [ os = "linux" ] diff --git a/xapi-stdext-unix.opam.template b/xapi-stdext-unix.opam.template index ae75bf72ee5..ae1fb3e0f99 100644 --- a/xapi-stdext-unix.opam.template +++ b/xapi-stdext-unix.opam.template @@ -1,2 +1,2 @@ depexts: ["linux-headers"] {os-distribution = "alpine"} -available: [ os = "macos" | os = "linux" ] +available: [ os = "linux" ] diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 30861bf3dc1..ee7603fdc4b 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -7,12 +7,12 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext.opam b/xapi-stdext.opam index e2654f782ab..c0e91ff6bd7 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -8,7 +8,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "2.0"} + "dune" {>= "2.7"} "xapi-stdext-date" {= version} "xapi-stdext-encodings" {= version} "xapi-stdext-pervasives" {= version} @@ -16,9 +16,11 @@ depends: [ "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} + "xapi-fdcaps" {= version} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build"