From 4c29a1e1b75e6880412fdecb1bb066992c650a1d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 15 Feb 2024 17:23:11 +0000 Subject: [PATCH 01/22] [maintenance]: disable implicit transitive deps MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This forces us to fully declare the dependencies of our code, and not rely on libraries that are brought in only as transitive dependencies of other libraries we happen to link to. E.g. if our module A depends on library X, which itself depends on library Y, then currently by linking X we also get Y linked and accessible from A directly. If code in module A uses both module X and Y *directly* then it needs to declare a dependency on both when implicit transitive deps are off or it gets a link failure (typically an error about a module or type being abstract). If the code in module A only uses module X then no change is needed (X can still use Y and the final executable will link both, it is just a question of what is visible and callable from A directly). This is especially useful when writing new code to get dependencies correct from the beginning. Signed-off-by: Edwin Török (cherry picked from commit 72034304327870c263485f9aa78c47d8023c6098) --- dune-project | 1 + ocaml/database/dune | 1 + ocaml/forkexecd/lib/dune | 1 + ocaml/libs/ezxenstore/core/dune | 6 ++++-- ocaml/libs/ezxenstore/lib/dune | 4 ++-- ocaml/libs/ezxenstore/lib_test/dune | 2 +- ocaml/libs/ezxenstore/watch/dune | 5 ++++- ocaml/libs/http-lib/dune | 3 +++ ocaml/libs/tracing/dune | 5 +++++ ocaml/libs/uuid/dune | 2 +- ocaml/libs/vhd/cli/dune | 2 +- ocaml/libs/vhd/vhd_format/dune | 2 +- ocaml/libs/vhd/vhd_format_lwt/dune | 2 +- ocaml/libs/xapi-inventory/lib/dune | 2 +- ocaml/libs/xapi-rrd/lib/dune | 1 + ocaml/libs/xapi-rrd/lib_test/dune | 2 ++ ocaml/message-switch/async/dune | 1 + ocaml/message-switch/core_test/async/dune | 2 ++ ocaml/squeezed/src/dune | 1 + ocaml/tests/alerts/dune | 2 ++ ocaml/tests/dune | 18 ++++++++++++++---- ocaml/xapi-cli-server/dune | 1 + ocaml/xapi-client/dune | 2 +- ocaml/xapi-guard/lib/dune | 17 +++++++++++++++++ ocaml/xapi-guard/src/dune | 1 + ocaml/xapi-guard/test/dune | 2 ++ ocaml/xapi-idl/guard/varstored/dune | 2 +- ocaml/xapi-idl/lib/dune | 1 + ocaml/xapi-idl/lib_test/dune | 4 +++- ocaml/xapi-storage-script/dune | 1 - ocaml/xapi/dune | 7 +++++-- ocaml/xcp-rrdd/bin/rrdd/dune | 2 ++ ocaml/xcp-rrdd/bin/rrdp-iostat/dune | 1 + ocaml/xe-cli/dune | 1 + ocaml/xen-api-client/async/dune | 2 ++ ocaml/xenopsd/dbgring/dune | 1 + ocaml/xenopsd/lib/dune | 1 + ocaml/xenopsd/pvs/dune | 2 +- ocaml/xenopsd/xc/dune | 1 + ocaml/xs-trace/dune | 2 ++ ocaml/xxhash/lib/dune | 1 + 41 files changed, 95 insertions(+), 22 deletions(-) diff --git a/dune-project b/dune-project index 747fc62b133..177eeeb7a79 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,7 @@ (lang dune 2.0) (formatting (enabled_for ocaml)) +(implicit_transitive_deps false) (generate_opam_files true) (source (github xapi-project/xen-api)) diff --git a/ocaml/database/dune b/ocaml/database/dune index 0b0c71425ff..9d5f1fac7ef 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -40,6 +40,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 3ed1d4eb891..2830cd13937 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -12,6 +12,7 @@ xapi-log xapi-stdext-pervasives xapi-stdext-unix + rpclib.xml ) (preprocess (pps ppx_deriving_rpc))) 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..be0043e519a 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 @@ -39,6 +40,7 @@ (libraries astring http_lib + ipaddr polly threads.posix xapi-log @@ -55,6 +57,7 @@ (libraries alcotest dune-build-info + fmt http_lib ) ) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 05a0ba27fda..bd2d8fd768b 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -6,8 +6,13 @@ cohttp-posix ptime ptime.clock.os + re rpclib.core rpclib.json + result + rresult + uri + threads.posix xapi-log xapi-open-uri xapi-stdext-threads 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/message-switch/async/dune b/ocaml/message-switch/async/dune index a0a1beb8c19..28ee31ecfa5 100644 --- a/ocaml/message-switch/async/dune +++ b/ocaml/message-switch/async/dune @@ -10,6 +10,7 @@ core core_unix core_kernel + core_unix.time_unix message-switch-core ) ) 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/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/dune b/ocaml/tests/dune index 93bf4b66ddf..1379bcc8a78 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -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,33 @@ (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) (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)) (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..88e9d6887d9 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 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 45d5e67aaf9..9bdabb84b26 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -64,6 +64,7 @@ cstruct base64 cohttp + cohttp_posix domain-name ezxenstore.core fmt @@ -72,6 +73,7 @@ gzip hex http_lib + httpsvr ipaddr message-switch-core message-switch-unix @@ -83,6 +85,7 @@ pciutil pci ptime + ptime.clock.os rpclib.core rpclib.json rpclib.xml @@ -109,7 +112,7 @@ x509 xapi_aux xapi-backtrace - xapi-consts + (re_export xapi-consts) xapi-consts.xapi_version xapi-client xapi-cli-protocol @@ -136,7 +139,7 @@ xapi-log xapi-open-uri xapi-rrd - xapi-types + (re_export xapi-types) xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives 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 e389949c281..94fd8f4c10c 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 3a3e04b6e83..7ba26342471 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -4,7 +4,9 @@ (public_name xs-trace) (package xapi) (libraries + uri tracing 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 From 027874268977c8bcdfa72b92afa54ada75b49d53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 29 Jan 2024 17:45:42 +0000 Subject: [PATCH 02/22] fix(dune): avoid "module unavailable" errors when running dune build @check MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bytecode builds for `http_lib` are disabled due to '(modes best)', and that means that anything that depends on it must have it disabled too to avoid this warning. Avoids these kinds of warnings: ``` File "_none_", line 1: Error: Module `Buf_io' is unavailable (required by `Http_svr') ``` Signed-off-by: Edwin Török --- ocaml/database/dune | 1 + ocaml/libs/http-lib/dune | 2 ++ ocaml/tests/common/dune | 1 + ocaml/tests/dune | 3 ++- ocaml/xapi/dune | 1 + 5 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ocaml/database/dune b/ocaml/database/dune index 9d5f1fac7ef..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 diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index be0043e519a..dae6e86e669 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -36,6 +36,7 @@ (library (name httpsvr) (wrapped false) + (modes best) (modules http_svr http_proxy server_io) (libraries astring @@ -53,6 +54,7 @@ (tests (names http_test radix_tree_test) (package http-lib) + (modes (best exe)) (modules http_test radix_tree_test) (libraries alcotest 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 1379bcc8a78..d1f8df151af 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 @@ -130,6 +130,7 @@ (test (name test_observer) (package xapi) +(modes (best exe)) (modules test_observer) (libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std)) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 9bdabb84b26..76ce076be7a 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 From 514f13659cde44a7c2e73f923a180043a8c053b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 13:18:43 +0000 Subject: [PATCH 03/22] CP-47001: [xapi-fdcaps]: dune plumbing for new library MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be a new library that will provide a more type-safe interface to file descriptor operations. Useful on its own, but also for testing stdext. Minimal dependencies, only Unix (and Alcotest for testing). Signed-off-by: Edwin Török --- dune-project | 10 ++++++++ lib/xapi-fdcaps/dune | 7 ++++++ lib/xapi-fdcaps/test/dune | 5 ++++ lib/xapi-fdcaps/test/test_xapi_fdcaps.ml | 0 lib/xapi-fdcaps/test/test_xapi_fdcaps.mli | 0 xapi-fdcaps.opam | 29 +++++++++++++++++++++++ 6 files changed, 51 insertions(+) create mode 100644 lib/xapi-fdcaps/dune create mode 100644 lib/xapi-fdcaps/test/dune create mode 100644 lib/xapi-fdcaps/test/test_xapi_fdcaps.ml create mode 100644 lib/xapi-fdcaps/test/test_xapi_fdcaps.mli create mode 100644 xapi-fdcaps.opam diff --git a/dune-project b/dune-project index 177eeeb7a79..49bae3dc81a 100644 --- a/dune-project +++ b/dune-project @@ -358,3 +358,13 @@ (odoc :with-doc) ) ) + +(package + (name xapi-fdcaps) + (synopsis "Static capabilities for file descriptor operations") + (depends + (alcotest :with-test) + base-unix + fmt + ) +) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune new file mode 100644 index 00000000000..1b0f0734da5 --- /dev/null +++ b/lib/xapi-fdcaps/dune @@ -0,0 +1,7 @@ +; Keep dependencies minimal here, ideally just OCaml stdlib +; This will be used to test other functions in stdext, so it should not itself rely on other stdext libs! +(library + (public_name xapi-fdcaps) + (name xapi_fdcaps) + (libraries unix) +) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune new file mode 100644 index 00000000000..8f304ecc5dd --- /dev/null +++ b/lib/xapi-fdcaps/test/dune @@ -0,0 +1,5 @@ +(test + (package xapi-fdcaps) + (name test_xapi_fdcaps) + (libraries xapi_fdcaps alcotest) +) diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml b/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml new file mode 100644 index 00000000000..e69de29bb2d diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.mli b/lib/xapi-fdcaps/test/test_xapi_fdcaps.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam new file mode 100644 index 00000000000..6c5d05e2465 --- /dev/null +++ b/xapi-fdcaps.opam @@ -0,0 +1,29 @@ +# 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.0"} + "alcotest" {with-test} + "base-unix" + "fmt" +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" From 4c2682476f6853e2cc0a6a9436e4f193922ac227 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 13:24:18 +0000 Subject: [PATCH 04/22] CP-47001: [xapi-fd-test]: dune plumbing for a new test framework MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be a test framework providing QCheck generators and properties for testing file descriptor operations. It will try to generate: * different kinds of file descriptors * actual data written/read on the other end of pipes and socket pairs * different speeds and delays on the other end to find buffering bugs * file descriptors that are >1024 to find bugs with select Signed-off-by: Edwin Török --- dune-project | 14 ++ lib/xapi-fd-test/dune | 6 + lib/xapi-fd-test/test/dune | 6 + .../test/test_xapi_fd_test.ml} | 0 .../test/test_xapi_fd_test.mli} | 0 lib/xapi-fdcaps/dune | 2 +- lib/xapi-fdcaps/safefd.ml | 185 ++++++++++++++++++ lib/xapi-fdcaps/safefd.mli | 115 +++++++++++ lib/xapi-fdcaps/test/dune | 6 +- lib/xapi-fdcaps/test/test_safefd.ml | 123 ++++++++++++ lib/xapi-fdcaps/test/test_safefd.mli | 0 xapi-fd-test.opam | 32 +++ xapi-stdext.opam | 1 + 13 files changed, 486 insertions(+), 4 deletions(-) create mode 100644 lib/xapi-fd-test/dune create mode 100644 lib/xapi-fd-test/test/dune rename lib/{xapi-fdcaps/test/test_xapi_fdcaps.ml => xapi-fd-test/test/test_xapi_fd_test.ml} (100%) rename lib/{xapi-fdcaps/test/test_xapi_fdcaps.mli => xapi-fd-test/test/test_xapi_fd_test.mli} (100%) create mode 100644 lib/xapi-fdcaps/safefd.ml create mode 100644 lib/xapi-fdcaps/safefd.mli create mode 100644 lib/xapi-fdcaps/test/test_safefd.ml create mode 100644 lib/xapi-fdcaps/test/test_safefd.mli create mode 100644 xapi-fd-test.opam diff --git a/dune-project b/dune-project index 49bae3dc81a..26944770d8d 100644 --- a/dune-project +++ b/dune-project @@ -275,6 +275,7 @@ (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) (xapi-stdext-zerocheck (= :version)) + (xapi-fdcaps (= :version)) ) ) @@ -368,3 +369,16 @@ fmt ) ) + +(package + (name xapi-fd-test) + (synopsis "Test framework for file descriptor operations") + (depends + (alcotest :with-test) + base-unix + fmt + (mtime (>= 2.0.0)) + logs + (qcheck-core (>= 0.21.2)) + ) +) diff --git a/lib/xapi-fd-test/dune b/lib/xapi-fd-test/dune new file mode 100644 index 00000000000..b2a0d2fe007 --- /dev/null +++ b/lib/xapi-fd-test/dune @@ -0,0 +1,6 @@ +; This will be used to test stdext itself, so do not depend on stdext here +(library + (public_name xapi-fd-test) + (name xapi_fd_test) + (libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os) +) diff --git a/lib/xapi-fd-test/test/dune b/lib/xapi-fd-test/test/dune new file mode 100644 index 00000000000..10b800a0290 --- /dev/null +++ b/lib/xapi-fd-test/test/dune @@ -0,0 +1,6 @@ +; This is a test framework, but we still need to test it +(test + (package xapi-fd-test) + (name test_xapi_fd_test) + (libraries xapi_fd_test alcotest) +) diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml b/lib/xapi-fd-test/test/test_xapi_fd_test.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_xapi_fdcaps.ml rename to lib/xapi-fd-test/test/test_xapi_fd_test.ml diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.mli b/lib/xapi-fd-test/test/test_xapi_fd_test.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_xapi_fdcaps.mli rename to lib/xapi-fd-test/test/test_xapi_fd_test.mli diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 1b0f0734da5..6daf1416607 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -3,5 +3,5 @@ (library (public_name xapi-fdcaps) (name xapi_fdcaps) - (libraries unix) + (libraries fmt unix) ) diff --git a/lib/xapi-fdcaps/safefd.ml b/lib/xapi-fdcaps/safefd.ml new file mode 100644 index 00000000000..1d0d3a92b6d --- /dev/null +++ b/lib/xapi-fdcaps/safefd.ml @@ -0,0 +1,185 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let string_of_file_kind = + let open Unix in + function + | S_REG -> + "regular file" + | S_BLK -> + "block device" + | S_CHR -> + "character device" + | S_DIR -> + "directory" + | S_LNK -> + "symlink" + | S_FIFO -> + "FIFO/pipe" + | S_SOCK -> + "socket" + +let pp_kind = Fmt.of_to_string string_of_file_kind + +module Identity = struct + type t = { + kind: Unix.file_kind + ; device: int + ; inode: int (* should be int64? *) + } + + let of_fd fd = + let open Unix.LargeFile in + let stat = fstat fd in + {kind= stat.st_kind; device= stat.st_dev; inode= stat.st_ino} + + let same a b = a.kind = b.kind && a.device = b.device && a.inode = b.inode + + let pp = + Fmt.( + record + ~sep:Fmt.(any ", ") + [ + field "kind" (fun t -> t.kind) pp_kind + ; field "device" (fun t -> t.device) int + ; field "inode" (fun t -> t.inode) int + ] + ) +end + +type t = { + fd: (Unix.file_descr, Printexc.raw_backtrace) result Atomic.t + ; opened_at: Printexc.raw_backtrace + ; original: Identity.t +} + +let pp ppf t = + (* print only essential info that fits on a single line *) + Fmt.pf ppf "@[FD %a: %a@]" + (Fmt.result ~ok:Fmt.(any "open") ~error:Fmt.(any "closed")) + (Atomic.get t.fd) Identity.pp t.original + +let pp_closed ppf bt = + let exception Closed_at in + Fmt.exn_backtrace ppf (Closed_at, bt) + +let pp_opened_at ppf bt = + let exception Opened_at in + Fmt.exn_backtrace ppf (Opened_at, bt) + +let dump = + Fmt.( + Dump.( + record + [ + field "fd" + (fun t -> Atomic.get t.fd) + Fmt.Dump.(result ~ok:(any "opened") ~error:pp_closed) + ; field "opened_at" (fun t -> t.opened_at) pp_opened_at + ; field "original" (fun t -> t.original) Identity.pp + ] + ) + ) + +let location () = + (* We could raise and immediately catch an exception but that will have a very short stacktrace, + [get_callstack] is better. + *) + Printexc.get_callstack 1000 + +let nop = + { + fd= Atomic.make (Error (location ())) + ; opened_at= Printexc.get_callstack 0 + ; original= Identity.of_fd Unix.stdin + } + +let check_exn ~caller t fd = + let actual = Identity.of_fd fd in + if not (Identity.same t.original actual) then ( + let msg = + Format.asprintf "@[File descriptor mismatch: %a <> %a@]" Identity.pp + t.original Identity.pp actual + in + (* invalidate FD so nothing else uses it anymore, we know it points to elsewhere now *) + Atomic.set t.fd (Error (location ())) ; + (* raise backtrace with original open location *) + Printexc.raise_with_backtrace + Unix.(Unix_error (EBADF, caller, msg)) + t.opened_at + ) + +let close_common_exn t = + let closed = Error (location ()) in + (* ensure noone else can access it, before we close it *) + match Atomic.exchange t.fd closed with + | Error _ as e -> + (* put back the original backtrace *) + Atomic.set t.fd e ; e + | Ok fd -> + check_exn ~caller:"close_common_exn" t fd ; + Ok (Unix.close fd) + +let close_exn t = + match close_common_exn t with + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + (* raise with previous close's backtrace *) + Printexc.raise_with_backtrace ebadf bt + | Ok () -> + () + +let idempotent_close_exn t = + let (_ : _ result) = close_common_exn t in + () + +let leak_count = Atomic.make 0 + +let leaked () = Atomic.get leak_count + +let finalise t = + match Atomic.get t.fd with + | Ok _ -> + Atomic.incr leak_count ; + if Sys.runtime_warnings_enabled () then + Format.eprintf "@.Warning: leaked file descriptor detected:@,%a@]@." + pp_opened_at t.opened_at + | Error _ -> + () + +let of_file_descr fd = + let v = + { + fd= Atomic.make (Ok fd) + ; opened_at= location () + ; original= Identity.of_fd fd + } + in + Gc.finalise finalise v ; v + +let unsafe_to_file_descr_exn t = + match Atomic.get t.fd with + | Ok fd -> + fd + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + Printexc.raise_with_backtrace ebadf bt + +let with_fd_exn t f = + let fd = unsafe_to_file_descr_exn t in + let r = f fd in + check_exn ~caller:"with_fd_exn" t fd ; + r + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore diff --git a/lib/xapi-fdcaps/safefd.mli b/lib/xapi-fdcaps/safefd.mli new file mode 100644 index 00000000000..710d1a5ee47 --- /dev/null +++ b/lib/xapi-fdcaps/safefd.mli @@ -0,0 +1,115 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Safe wrapper around {!type:Unix.file_descr} that detects "use after close" errors + + {!type:Unix.file_descr} is just an integer and cannot track whether {!val:Unix.close} has been called. + File descriptor numbers are reused by newly open file descriptors, so using a file descriptor that is already closed + doesn't always result in a visible error, but is nevertheless a programming error that should be detected. + + E.g. the following sequence would write data to the wrong file ([fd2] instead of [fd1]), + and raise no errors at runtime: + {[ + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.close fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.write_substring fd1 "test" 0 4; + Unix.close fd2 + ]} + + This module introduces a lightweight wrapper around {!type:Unix.file_descr}, + and detects attempts to use a file descriptor after it has been closed: + {[ + open Xapi_fdcaps + + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.close_exn fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.with_fd_exn fd1 (fun fd -> Unix.write_substring fd "test" 0 4); + ]} + + It raises {!val:Unix.EBADF}: + {[ Exception: Unix.Unix_error(Unix.EBADF, "unsafe_to_file_descr_exn", "") ]} + + The callback of {!val:with_fd_exn} has access to the underlying {!type:Unix.file_descr}, + and may accidentally call {!val:Unix.close}. + + To detect that {!val:with_fd_exn} calls {!val:Unix.LargeFile.fstat} to check that the file descriptor + remained the "same" after the call. + File descriptors are considered to be the same if their kind, device and inode remain unchanged + (obviously other parts of the stat structure such as timestamps and size may change between calls). + This doesn't detect all bugs, but detects most common bugs + (hardlinked files will still show up as the same but the file position may have been different, which is not checked). + + The extra system calls have an overhead so an unsafe version is available, but not documented (it should only be used internally by other modules in {!mod:Xapi_fdcaps}). + + With the safe wrapper we also have a non-integer type that we can attach a finaliser too. + This is used to detect and close leaked file descriptors safely (by checking that it is "the same" that we originally opened). +*) + +(** a file descriptor that is safe against double close *) +type t + +val of_file_descr : Unix.file_descr -> t +(** [of_file_descr fd] wraps [fd]. + + *) + +val idempotent_close_exn : t -> unit +(** [idempotent_close_exn t] closes [t], and doesn't raise an exception if [t] is already closed. + Other exceptions may still escape (e.g. if the underlying [close] has reported an [ENOSPC] or [EIO] error). +*) + +val close_exn : t -> unit +(** [close_exn t] closes t and raises an exception if [t] is already closed. + + @raises Unix_error(Unix.EBADF,_,_) if [t] is already closed. +*) + +val with_fd_exn : t -> (Unix.file_descr -> 'a) -> 'a +(** [with_fd_exn t f] calls [f fd] with the underlying file descriptor. + [f] must not close [fd]. + + @raises Unix_error(Unix.EBADF,_,_) if the file descriptor is not the same after [f] terminates. +*) + +val nop : t +(** [nop] is a file descriptor that is always closed and no operations are valid on it. *) + +val pp_kind : Format.formatter -> Unix.file_kind -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +val pp : Format.formatter -> t -> unit +(** [pp formatter t] pretty prints information about [t] on [formatter]. *) + +val dump : Format.formatter -> t -> unit +(** [dump formatter t] prints all the debug information available about [t] on [formatter] *) + +(**/**) + +(* For small wrappers and high frequency calls like [read] and [write]. + Should only be used by the wrappers in {!mod:Operations}, hence hidden from the documentation. +*) + +val setup : unit -> unit +(** [setup ()] sets up a [SIGPIPE] handler. + With the handler set up a broken pipe will result in a [Unix.EPIPE] exception instead of killing the program *) + +val leaked : unit -> int +(** [leaked ()] is a count of leaked file descriptors detected. + Run [Gc.full_major ()] to get an accurate count before calling this *) + +(**/**) + +val unsafe_to_file_descr_exn : t -> Unix.file_descr diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index 8f304ecc5dd..b20b371663d 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,5 +1,5 @@ -(test +(tests (package xapi-fdcaps) - (name test_xapi_fdcaps) - (libraries xapi_fdcaps alcotest) + (names test_safefd) + (libraries xapi_fdcaps alcotest fmt) ) diff --git a/lib/xapi-fdcaps/test/test_safefd.ml b/lib/xapi-fdcaps/test/test_safefd.ml new file mode 100644 index 00000000000..ea1b1343410 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_safefd.ml @@ -0,0 +1,123 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps +open Safefd + +let make_safefd () = + let rd, wr = Unix.pipe ~cloexec:true () in + (of_file_descr rd, of_file_descr wr) + +let test_safefd_regular () = + let rd, wr = Unix.pipe ~cloexec:true () in + let rd, wr = (of_file_descr rd, of_file_descr wr) in + let (_ : Unix.LargeFile.stats) = with_fd_exn rd Unix.LargeFile.fstat + and (_ : Unix.LargeFile.stats) = with_fd_exn wr Unix.LargeFile.fstat in + close_exn rd ; close_exn wr + +let test_safefd_double_close () = + let rd, wr = make_safefd () in + close_exn rd ; + close_exn wr ; + let exn = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "double close" exn (fun () -> close_exn wr) + +let test_safefd_idempotent_close () = + let rd, wr = make_safefd () in + close_exn rd ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr + +let test_safefd_unix_close () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "fstat", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr Unix.close + ) + +let remove_unix_error_arg f = + try f () + with Unix.Unix_error (code, fn, _) -> + (* remove arg, so we can match with [Alcotest.check_raises] *) + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Unix.Unix_error (code, fn, "")) bt + +let with_fd_exn f arg = remove_unix_error_arg (fun () -> with_fd_exn f arg) + +let close_reuse fd = + Unix.close fd ; + (* open and leak fd, this should reuse the FD number of [fd], but we should be able to detect via stat *) + let _, _ = Unix.pipe () in + () + +let test_safefd_unix_close_reuse () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "with_fd_exn", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr close_reuse + ) + +let leak () = + let rd, wr = make_safefd () in + close_exn rd ; + (* leak wr *) + unsafe_to_file_descr_exn wr + +let test_safefd_finalised () = + let _leaked_fd : Unix.file_descr = leak () in + Gc.full_major () ; + Alcotest.( + check' int ~msg:"leak detected" ~expected:2 ~actual:(Safefd.leaked ()) + ) + +let test_pp_and_dump () = + let a, b = make_safefd () in + Format.printf "a: %a@,b: %a@." Safefd.pp a Safefd.pp b ; + Format.printf "a: %a@,b: %a@." Safefd.dump a Safefd.dump b + +let test_nop () = + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "nop close raises" ebadf (fun () -> close_exn nop) + +let test_unsafe_closed () = + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + dump Fmt.stdout nop ; + Alcotest.check_raises "unsafe raises" ebadf (fun () -> + let (_ : Unix.file_descr) = unsafe_to_file_descr_exn nop in + () + ) + +let tests_safefd = + Alcotest. + [ + test_case "nop" `Quick test_nop + ; test_case "regular ops" `Quick test_safefd_regular + ; test_case "double close detected" `Quick test_safefd_double_close + ; test_case "idempotent close" `Quick test_safefd_idempotent_close + ; test_case "Unix.close detected" `Quick test_safefd_unix_close + ; test_case "Unix.close detected after reuse" `Quick + test_safefd_unix_close_reuse + ; test_case "FD leak detected" `Quick test_safefd_finalised + ; test_case "test pp and dump" `Quick test_pp_and_dump + ; test_case "unsafe of closed fd" `Quick test_unsafe_closed + ] + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" [("safefd", tests_safefd)] diff --git a/lib/xapi-fdcaps/test/test_safefd.mli b/lib/xapi-fdcaps/test/test_safefd.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/xapi-fd-test.opam b/xapi-fd-test.opam new file mode 100644 index 00000000000..56801434c62 --- /dev/null +++ b/xapi-fd-test.opam @@ -0,0 +1,32 @@ +# 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.0"} + "alcotest" {with-test} + "base-unix" + "fmt" + "mtime" {>= "2.0.0"} + "logs" + "qcheck-core" {>= "0.21.2"} +] +build: [ + ["dune" "subst"] {pinned} + [ + "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-stdext.opam b/xapi-stdext.opam index e2654f782ab..088e3a820d5 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -16,6 +16,7 @@ depends: [ "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} + "xapi-fdcaps" {= version} ] build: [ ["dune" "subst"] {pinned} From 5b0ac7b4b8d1eafe88c38e3af2ae8974ec5e9178 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 15 Dec 2023 17:24:16 +0000 Subject: [PATCH 05/22] CP-47001: [xapi-fdcaps]: add -principal flag MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We are going to use type-level constraints a lot. Try to future proof it by using the recommended compiler flag. `ocamlc` says this about `-principal`: > When using labelled arguments and/or polymorphic methods, this flag is required to > ensure future versions of the compiler will be able to infer types correctly, even if internal algorithms change Signed-off-by: Edwin Török --- lib/xapi-fdcaps/dune | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 6daf1416607..0891178f2f2 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -3,5 +3,6 @@ (library (public_name xapi-fdcaps) (name xapi_fdcaps) - (libraries fmt unix) + (libraries fmt unix threads.posix) + (flags (:standard -principal)) ) From a975edf3e1fd31bef62fa45bff7a5f2ef9e65fc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 15 Dec 2023 17:26:16 +0000 Subject: [PATCH 06/22] CP-47001: [xapi-fdcaps]: optional coverage support MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is not enabled by default (but bisect-ppx is nevertheless a build-time dependency) Usage: `make coverage` Signed-off-by: Edwin Török --- .gitignore | 1 + Makefile | 7 ++++++- dune-project | 3 ++- lib/xapi-fdcaps/dune | 3 +++ xapi-fd-test.opam | 5 +++-- xapi-fdcaps.opam | 6 ++++-- xapi-rrd-transport.opam | 2 +- xapi-rrdd-plugin.opam | 2 +- xapi-stdext-date.opam | 4 ++-- xapi-stdext-encodings.opam | 4 ++-- xapi-stdext-pervasives.opam | 4 ++-- xapi-stdext-std.opam | 4 ++-- xapi-stdext-threads.opam | 4 ++-- xapi-stdext-unix.opam | 4 ++-- xapi-stdext-zerocheck.opam | 4 ++-- xapi-stdext.opam | 5 +++-- 16 files changed, 38 insertions(+), 24 deletions(-) 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 a57871a5c4e..45a0b3e6b09 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 26944770d8d..3f674e4adf8 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (implicit_transitive_deps false) @@ -367,6 +367,7 @@ (alcotest :with-test) base-unix fmt + (bisect_ppx :with-test) ) ) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 0891178f2f2..cb3c54ea189 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -5,4 +5,7 @@ (name xapi_fdcaps) (libraries fmt unix threads.posix) (flags (:standard -principal)) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) ) diff --git a/xapi-fd-test.opam b/xapi-fd-test.opam index 56801434c62..d6887267659 100644 --- a/xapi-fd-test.opam +++ b/xapi-fd-test.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"} "alcotest" {with-test} "base-unix" "fmt" "mtime" {>= "2.0.0"} "logs" "qcheck-core" {>= "0.21.2"} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam index 6c5d05e2465..c4428d7e0bc 100644 --- a/xapi-fdcaps.opam +++ b/xapi-fdcaps.opam @@ -7,13 +7,15 @@ 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"} "alcotest" {with-test} "base-unix" "fmt" + "bisect_ppx" {with-test} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" 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..09449f30273 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.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" "base-threads" "base-unix" @@ -15,7 +15,7 @@ depends: [ "xapi-stdext-pervasives" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index f8e709afe7f..b067d6d030b 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.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.0"} "base-unix" "fd-send-recv" {>= "2.0.0"} @@ -16,7 +16,7 @@ depends: [ "xapi-stdext-pervasives" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" 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 088e3a820d5..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} @@ -17,9 +17,10 @@ depends: [ "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} "xapi-fdcaps" {= version} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" From 89e95b42fb3c92fff58abce980bf08e0b1d3e688 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Dec 2023 17:07:58 +0000 Subject: [PATCH 07/22] CP-47001: [xapi-fdcaps]: add properties module and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Lightweight wrapper using polymorphic variants to track read, write, and file kind properties on file descriptors. We only track the property at the time the file descriptor was opened. This prevents bugs like accidentally swapping the read and write ends of a pipe, or attempting to run an operation on a file descriptor that would alway s fail (e.g. setting a socket timeout on a pipe) Write tests using cram-style expect tests that the operations we expect to be forbidden by this type system are actually forbidden. The error messages may be compiler version dependent, so only run them on OCaml 4.14.1 for now. Signed-off-by: Edwin Török --- dune-project | 1 + lib/xapi-fdcaps/properties.ml | 122 ++++++++++++++ lib/xapi-fdcaps/properties.mli | 192 +++++++++++++++++++++++ lib/xapi-fdcaps/test/dune | 6 +- lib/xapi-fdcaps/test/properties.t | 15 ++ lib/xapi-fdcaps/test/test_properties.ml | 94 +++++++++++ lib/xapi-fdcaps/test/test_properties.mli | 0 7 files changed, 429 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-fdcaps/properties.ml create mode 100644 lib/xapi-fdcaps/properties.mli create mode 100644 lib/xapi-fdcaps/test/properties.t create mode 100644 lib/xapi-fdcaps/test/test_properties.ml create mode 100644 lib/xapi-fdcaps/test/test_properties.mli diff --git a/dune-project b/dune-project index 3f674e4adf8..44b3b3c6722 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,7 @@ (lang dune 2.7) (formatting (enabled_for ocaml)) +(cram enable) (implicit_transitive_deps false) (generate_opam_files true) diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml new file mode 100644 index 00000000000..9e359a9b471 --- /dev/null +++ b/lib/xapi-fdcaps/properties.ml @@ -0,0 +1,122 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type (+!'a, +!'b) props = {rw: 'a; kind: 'b} + +type rdonly = [`rdonly] + +type wronly = [`wronly] + +type rdwr = [`rdwr] + +let pp_rw fmt = + Fmt.of_to_string + (function #rdonly -> "RDONLY" | #wronly -> "WRONLY" | #rdwr -> "RDWR") + fmt + +type reg = [`reg] + +type blk = [`blk] + +type chr = [`chr] + +type dir = [`dir] + +type lnk = [`lnk] + +type fifo = [`fifo] + +type sock = [`sock] + +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +let to_unix_kind = + let open Unix in + function + | #reg -> + S_REG + | #blk -> + S_BLK + | #chr -> + S_CHR + | #dir -> + S_DIR + | #lnk -> + S_LNK + | #fifo -> + S_FIFO + | #sock -> + S_SOCK + +let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt + +let pp fmt = + Fmt.( + record + ~sep:Fmt.(any ", ") + [field "rw" (fun t -> t.rw) pp_rw; field "kind" (fun t -> t.kind) pp_kind] + ) + fmt + +type readable = [rdonly | rdwr] + +type writable = [wronly | rdwr] + +type rw = [rdonly | wronly | rdwr] + +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +let as_readable ({rw= #readable; _} as t) = t + +let as_writable ({rw= #writable; _} as t) = t + +let as_readable_opt = function + | {rw= #readable; _} as x -> + Some x + | {rw= #wronly; _} -> + None + +let as_writable_opt = function + | {rw= #writable; _} as x -> + Some x + | {rw= #rdonly; _} -> + None + +type espipe = [fifo | sock] + +let as_kind_opt expected ({kind; _} as t) = + (* we cannot compare the values directly because we want to keep the type parameters distinct *) + match (kind, expected) with + | #reg, #reg -> + Some {t with kind= expected} + | #blk, #blk -> + Some {t with kind= expected} + | #chr, #chr -> + Some {t with kind= expected} + | #dir, #dir -> + Some {t with kind= expected} + | #lnk, #lnk -> + Some {t with kind= expected} + | #fifo, #fifo -> + Some {t with kind= expected} + | #sock, #sock -> + Some {t with kind= expected} + | #kind, #kind -> + None + +type seekable = [reg | blk] + +type truncatable = reg + +let make rw kind = {rw; kind} diff --git a/lib/xapi-fdcaps/properties.mli b/lib/xapi-fdcaps/properties.mli new file mode 100644 index 00000000000..0afc529c56a --- /dev/null +++ b/lib/xapi-fdcaps/properties.mli @@ -0,0 +1,192 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Static file property checking + + When file descriptors are open they have: + * a file kind: ({!type:reg}, {!type:blk), {!type:chr}, {!type:lnk}, {!type:fifo}, {!type:sock}) + * an open mode: {!type:readonly}, {!type:writeonly}, {!type:readwrite} depending on the {!type:Unix.open_flag} used + + Depending on these properties there are {!val:Unix} operations on file descriptors that always fail, e.g.: + * writing to a read-only file + * socket operation on non-socket + * seeking on a pipe + * ... + + The read-write property can also change at runtime: + * {!val:Unix.shutdown} can be used to shutdown the socket in either direction + + We track the property of the file at open time, and we reject operations that we can statically determine to always fail. + This doesn't guarantee the absence of runtime errors, but catches programming errors like accidentally swapping the read and write ends of a pipe, + or attempting to set a socket timeout on a pipe. + + We use polymorphic variants as type parameters to track these properties: they are simple to use and work well with type inference. + They also allow dispatching at runtime on the actual capabilities available, although they could be purely compile-time types (phantom types). + + Alternative approaches (typically with phantom types): + * abstract types as phantom type parameters: don't work well with type inference, and cannot express removing a property + * behavioural types (recursive polymorphic variants) can express removing a property, but error messages and type signatures become too long + * object phantom types strike a good balance between clarity of error messages and complexity of type signatures + + It'd be also possible to use purely boolean properties (capabilities), but that causes a long type signature, and allows expressing meaningless combinations, + such as a file that is both a socket and seekable, which is impossible. + Instead we directly map the concepts from the Unix module to a polymorphic variant (e.g. instead of separate read and write properties we have the 3 properties from the Unix module). + +{b References.} +{ul + {- Yaron Minsky. + {e {{:https://blog.janestreet.com/howto-static-access-control-using-phantom-types/}HOWTO: Static access control using phantom types}. 2008.}} + {- KC Sivaramakrishnan. + {e {{:https://kcsrk.info/ocaml/types/2016/06/30/behavioural-types/#file-descriptors}Behavioural types}. 2016.}} + {- Florian Angeletti. + {e {{:https://stackoverflow.com/a/55081337}Object phantom types}. 2019.}} +} +*) + +(** {1 File properties} + + Polymorphic type parameters for the set of properties a file descriptor may have on a given codepath. + E.g. {[> rdonly | wronly]} means that this codepath may be reached by a file descriptor with either of these properties, + although of course a file descriptor can only have one of these properties at a time. + + Usual rules for using polymorphic variants apply: + * when receiving a type declare an upper bound on what the code can handle, e.g. : {[< readable]} + * when returning a type declare a lower bound to make type inference/unification work, e.g. : {[> readable]} + + Naming conventions: + * [type property ] + * [val as_property : [< property] t -> [> property] t] + * [val as_property_opt: [< all] t -> [> property] t option] +*) + +(** file properties: {!type:rw}, {!type:kind} + + Upper bounds are avoided here to make the type usable in functors + *) +type (+!'a, +!'b) props + +(** {2 Read/write property} + + A file can be read-only, write-only, or read-write. +*) + +(** file opened with {!val:Unix.O_RDONLY} or the read end of a pipe *) +type rdonly = [`rdonly] + +(** file opened with {!val:Unix.O_WRONLY} or the write end of a pipe *) +type wronly = [`wronly] + +(** file opened with {!val:Unix.O_RDWR} or a socketpair *) +type rdwr = [`rdwr] + +(** file opened with either {!val:Unix.O_RDONLY} or {!val:Unix.O_RDWR} *) +type readable = [rdonly | rdwr] + +(** file opened with either {!val:Unix.O_WRONLY} or {!val:Unix.O_RDWR} *) +type writable = [wronly | rdwr] + +(** the read-write property *) +type rw = [rdonly | wronly | rdwr] + +val pp_rw : Format.formatter -> [< rw] -> unit +(** [pp_rw formatter rw] pretty prints the [rw] state on [formatter]. *) + +(** {2 File kind} *) + +(** A regular file, {!val:Unix.S_REG} *) +type reg = [`reg] + +(** A block device, {!val:Unix.S_BLK} *) +type blk = [`blk] + +(** A character device, {!val:Unix.S_CHR} *) +type chr = [`chr] + +(** A directory, {!val:Unix.S_DIR} *) +type dir = [`dir] + +(** A symbolic link, {!val:Unix.S_LNK} *) +type lnk = [`lnk] + +(** A pipe or FIFO, {!val:Unix.S_FIFO} *) +type fifo = [`fifo] + +(** A socket, {!val:Unix.S_SOCK} *) +type sock = [`sock] + +(** a {!type:Unix.file_kind} *) +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +val pp_kind : Format.formatter -> [< kind] -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +(** {2 Property type} *) + +(** upper bounds on properties *) +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +(** {2 Operations on read-write properties} *) + +val as_readable : ([< readable], 'a) t -> ([> readable], 'a) t +(** [as_readable t] requires [t] to be readable and ignores the writeonly property. *) + +val as_writable : ([< writable], 'a) t -> ([> writable], 'a) t +(** [as_writable t] requires [t] to be writable and ignores the readonly property. *) + +val as_readable_opt : ([< rw], 'a) t -> ([> readable], 'a) t option +(** [as_readable_opt t] tests for the presence of the readable property at runtime. + + @returns [Some t] when [t] is readable, and [None] otherwise +*) + +val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option +(** [as_writable_opt t] tests for the presence of the writable property at runtime. + + @returns [Some t] when [t] is writable, and [None] otherwise +*) + +(** {2 Operations on file kind properties} *) + +val to_unix_kind : kind -> Unix.file_kind +(** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) + +(** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) +type espipe = [fifo | sock] + +val as_kind_opt : ([< kind] as 'a) -> ('b, [< kind]) t -> ('b, 'a) t option +(** [as_kind_opt kind t] checks whether [t] is of type [kind]. + + @returns [Some t] if [t] is of type [kind], and [None] otherwise + *) + +(** {2 Properties derived from file kind} *) + +(** seek may be implementation defined on devices other than regular files or block devices. + + E.g. {!type:chr} devices would always return 0 when seeking, which doesn't follow the usual semantics of seek. +*) +type seekable = [reg | blk] + +(** truncate only works on regular files *) +type truncatable = reg + +(** {2 Create properties} *) + +val make : ([< rw] as 'a) -> ([< kind] as 'b) -> ('a, 'b) t +(** [make rw kind] builds a file property *) + +(** {2 Pretty printing} *) + +val pp : Format.formatter -> (_, _) t -> unit +(** [pp formatter t] pretty prints the properties on [formatter]. *) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index b20b371663d..60619b2c1aa 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,5 +1,9 @@ (tests (package xapi-fdcaps) - (names test_safefd) + (names test_safefd test_properties) (libraries xapi_fdcaps alcotest fmt) ) + +(cram + (deps (package xapi-fdcaps)) +) diff --git a/lib/xapi-fdcaps/test/properties.t b/lib/xapi-fdcaps/test/properties.t new file mode 100644 index 00000000000..51b37e0eaeb --- /dev/null +++ b/lib/xapi-fdcaps/test/properties.t @@ -0,0 +1,15 @@ +Check that we get compile errors when trying to use a read-only or write-only property with the opposite operation: + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_readable (make `wronly `reg) + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `wronly + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_writable (make `rdonly `reg) + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `rdonly diff --git a/lib/xapi-fdcaps/test/test_properties.ml b/lib/xapi-fdcaps/test/test_properties.ml new file mode 100644 index 00000000000..e72e179af51 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_properties.ml @@ -0,0 +1,94 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps.Properties + +(* compilation tests, failed ones are in [properties.t] *) +let () = + let (_ : (_, _) t) = as_readable (make `rdonly `reg) in + let (_ : (_, _) t) = as_writable (make `wronly `reg) in + let (_ : (_, _) t) = as_readable (make `rdwr `reg) in + let (_ : (_, _) t) = as_writable (make `rdwr `reg) in + let #espipe = `fifo in + let #espipe = `sock in + let #seekable = `reg in + let #seekable = `blk in + let #truncatable = `reg in + () + +(* test that unification works *) +let _any_file = function + | 0 -> + make `rdonly `reg + | 1 -> + make `rdonly `blk + | 2 -> + make `rdonly `chr + | 3 -> + make `rdonly `dir + | 4 -> + make `rdonly `sock + | _ -> + make `rdonly `fifo + +let all_rw = [`rdonly; `wronly; `rdwr] + +let test_as_rw_opt f expected_set = + let t = Alcotest.testable pp ( = ) in + all_rw + |> List.map @@ fun rw -> + let test () = + let prop = make rw `reg in + let expected = if List.mem rw expected_set then Some prop else None in + let msg = Fmt.str "as_%a_opt" pp_rw rw in + Alcotest.(check' @@ option t) ~msg ~expected ~actual:(f prop) + in + Alcotest.test_case (Fmt.to_to_string pp_rw rw) `Quick test + +let _test_pp prop = Alcotest.test_case (Fmt.to_to_string pp prop) `Quick ignore + +let all_kinds = [`reg; `blk; `chr; `dir; `lnk; `sock; `fifo] + +let test_to_unix_kind () = + let all_unix_kinds = + List.sort_uniq compare @@ all_kinds |> List.map to_unix_kind + in + Alcotest.(check' int) + ~msg:"to_unix_kind mapping is unique" ~expected:(List.length all_kinds) + ~actual:(List.length all_unix_kinds) + +let test_as_kind = + let t = Alcotest.testable pp ( = ) in + all_kinds + |> List.map @@ fun k1 -> + ( Fmt.str "as_kind_opt %a" pp_kind k1 + , all_kinds + |> List.map @@ fun k2 -> + let test () = + let prop = make `rdonly k2 in + let actual = as_kind_opt k1 prop in + let expected = if k1 = k2 then Some prop else None in + Alcotest.(check' @@ option t) ~msg:"as_kind_opt" ~expected ~actual + in + Alcotest.test_case (Fmt.to_to_string pp_kind k2) `Quick test + ) + +let tests = + let open Alcotest in + ("to_unix_kind", [test_case "to_unix_kind" `Quick test_to_unix_kind]) + :: ("as_readable_opt", test_as_rw_opt as_readable_opt [`rdonly; `rdwr]) + :: ("as_writable_opt", test_as_rw_opt as_writable_opt [`wronly; `rdwr]) + :: test_as_kind + +let () = Alcotest.run ~show_errors:true "test_capabilities" tests diff --git a/lib/xapi-fdcaps/test/test_properties.mli b/lib/xapi-fdcaps/test/test_properties.mli new file mode 100644 index 00000000000..e69de29bb2d From fd68005330489946c9850adf52262fc370a5e19c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Dec 2023 17:09:37 +0000 Subject: [PATCH 08/22] CP-47001: [xapi-fdcaps]: add operations module and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Use the capabilities module to wrap most Unix operations needed in testing Unixext Add a testsuite that checks that whenever the type says "never" the underlying file descriptor operation would indeed raise an exception. This ensures that the type constraints we declare are actually correct. The checks use unsafe operations that bypass the type layer. Similarly check that operations that are accepted by the type system and marked as "always" in the type succeed. Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 205 ++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 216 +++++++++++++++++++ lib/xapi-fdcaps/test/dune | 2 +- lib/xapi-fdcaps/test/test_operations.ml | 262 +++++++++++++++++++++++ lib/xapi-fdcaps/test/test_operations.mli | 0 5 files changed, 684 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-fdcaps/operations.ml create mode 100644 lib/xapi-fdcaps/operations.mli create mode 100644 lib/xapi-fdcaps/test/test_operations.ml create mode 100644 lib/xapi-fdcaps/test/test_operations.mli diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml new file mode 100644 index 00000000000..12e74d60681 --- /dev/null +++ b/lib/xapi-fdcaps/operations.ml @@ -0,0 +1,205 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Properties + +type +!'a props = { + props: ('b, 'c) Properties.props + ; custom_ftruncate: (int64 -> unit) option + ; fd: Safefd.t +} + constraint 'a = ('b, 'c) Properties.props + +type +!'a t = 'a props constraint 'a = (_, _) Properties.t + +type (+!'a, +!'b) make = ('a, 'b) Properties.t t + +let dump ppf = + Fmt.( + Dump.( + record + [ + field "props" (fun t -> t.props) pp + ; field "custom_ftruncate" + (fun t -> Option.is_some t.custom_ftruncate) + bool + ; field "fd" (fun t -> t.fd) Safefd.dump + ] + ) + ) + ppf + +let pp ppf = + Fmt.( + record + ~sep:Fmt.(any "; ") + [ + field "props" (fun t -> t.props) pp + ; field "custom_ftruncate" + (fun t -> Option.is_some t.custom_ftruncate) + bool + ; field "fd" (fun t -> t.fd) Safefd.pp + ] + ) + ppf + +let close t = Safefd.idempotent_close_exn t.fd + +let with_fd t f = + let finally () = close t in + Fun.protect ~finally (fun () -> f t) + +module Syntax = struct let ( let@ ) f x = f x end + +open Syntax + +let with_fd2 (fd1, fd2) f = + let@ fd1 = with_fd fd1 in + let@ fd2 = with_fd fd2 in + f (fd1, fd2) + +let make ?custom_ftruncate props fd : 'a t = + {fd= Safefd.of_file_descr fd; props; custom_ftruncate} + +let make_ro_exn kind fd = make (Properties.make `rdonly kind) fd + +let make_wo_exn kind fd = make (Properties.make `wronly kind) fd + +let make_rw_exn ?custom_ftruncate kind fd = + make (Properties.make `rdwr kind) ?custom_ftruncate fd + +let pipe () = + let kind = `fifo in + let ro, wo = Unix.pipe ~cloexec:true () in + (make_ro_exn kind ro, make_wo_exn kind wo) + +let socketpair domain typ proto = + let kind = `sock in + let fd1, fd2 = Unix.socketpair ~cloexec:true domain typ proto in + (make_rw_exn kind fd1, make_rw_exn kind fd2) + +let openfile_ro kind path flags = + make_ro_exn kind + @@ Unix.openfile path (Unix.O_RDONLY :: Unix.O_CLOEXEC :: flags) 0 + +let openfile_rw ?custom_ftruncate kind path flags = + make_rw_exn ?custom_ftruncate kind + @@ Unix.openfile path (Unix.O_RDWR :: Unix.O_CLOEXEC :: flags) 0 + +let openfile_wo kind path flags = + make_wo_exn kind + @@ Unix.openfile path (Unix.O_WRONLY :: Unix.O_CLOEXEC :: flags) 0 + +let creat path flags perm = + make_rw_exn `reg + @@ Unix.openfile path + (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags) + perm + +let dev_null_out () = openfile_wo `chr "/dev/null" [] + +let dev_null_in () = openfile_ro `chr "/dev/null" [] + +let dev_zero () = openfile_ro `chr "/dev/zero" [] + +let shutdown_recv t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_RECEIVE + +let shutdown_send t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND + +let shutdown_all t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL + +let ftruncate t size = + match t.custom_ftruncate with + | None -> + Unix.LargeFile.ftruncate (Safefd.unsafe_to_file_descr_exn t.fd) size + | Some f -> + f size + +let lseek t off whence = + Unix.LargeFile.lseek (Safefd.unsafe_to_file_descr_exn t.fd) off whence + +let read t buf off len = + Unix.read (Safefd.unsafe_to_file_descr_exn t.fd) buf off len + +let single_write_substring t buf off len = + Unix.single_write_substring (Safefd.unsafe_to_file_descr_exn t.fd) buf off len + +let set_nonblock t = Unix.set_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) + +let clear_nonblock t = Unix.clear_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) + +let with_tempfile ?size () f = + let name, ch = + Filename.open_temp_file ~mode:[Open_binary] "xapi_fdcaps" "tmp" + in + let finally () = + close_out_noerr ch ; + try Unix.unlink name with Unix.Unix_error (_, _, _) -> () + in + let@ () = Fun.protect ~finally in + let t = ch |> Unix.descr_of_out_channel |> make_wo_exn `reg in + let@ t = with_fd t in + size |> Option.iter (fun size -> ftruncate t size) ; + f (name, t) + +let check_output cmd args = + let cmd = Filename.quote_command cmd args in + let ch = Unix.open_process_in cmd in + let finally () = + try + let (_ : Unix.process_status) = Unix.close_process_in ch in + () + with _ -> () + in + Fun.protect ~finally @@ fun () -> + let out = In_channel.input_all ch |> String.trim in + match Unix.close_process_in ch with + | Unix.WEXITED 0 -> + out + | _ -> + failwith (Printf.sprintf "%s exited nonzero" cmd) + +let with_temp_blk ?(sector_size = 512) name f = + let blkdev = + check_output "losetup" + [ + "--show" + ; "--sector-size" + ; string_of_int sector_size + ; "--direct-io=on" + ; "--find" + ; name + ] + in + let custom_ftruncate size = + Unix.LargeFile.truncate name size ; + let (_ : string) = check_output "losetup" ["--set-capacity"; name] in + () + in + let finally () = + let (_ : string) = check_output "losetup" ["--detach"; blkdev] in + () + in + let@ () = Fun.protect ~finally in + let@ t = with_fd @@ openfile_rw ~custom_ftruncate `blk blkdev [] in + f (blkdev, t) + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore + +module For_test = struct + let unsafe_fd_exn t = Safefd.unsafe_to_file_descr_exn t.fd +end diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli new file mode 100644 index 00000000000..e320c681648 --- /dev/null +++ b/lib/xapi-fdcaps/operations.mli @@ -0,0 +1,216 @@ +(* + * 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 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 close : _ t -> unit +(** [close t] closes t. Doesn't raise an exception if it is already closed. + Other errors from the underlying {!val:Unix.close} are propagated. + *) + +val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make +(** [pipe ()] creates an unnamed pipe. + @see {!val:Unix.pipe} + *) + +val socketpair : + Unix.socket_domain + -> Unix.socket_type + -> int + -> ([> rdwr], [> sock]) make * ([> rdwr], [> sock]) make +(** [socketpair domain type protocol] creates a socket pair. + @see {!val:Unix.socketpair} + *) + +val openfile_ro : 'a -> string -> Unix.open_flag list -> ([> rdonly], 'a) make +(** [openfile_ro kind path flags] opens an existing [path] readonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_rw : + ?custom_ftruncate:(int64 -> unit) + -> 'a + -> string + -> Unix.open_flag list + -> ([> rdwr], 'a) make +(** [openfile_rw kind path flags] opens an existing [path] readwrite. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_wo : 'a -> string -> Unix.open_flag list -> ([> wronly], 'a) make +(** [openfile_wo kind path flags] opens an existing [path] writeonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val creat : string -> Unix.open_flag list -> int -> ([> rdwr], [> reg]) make +(** [creat path flags perms] creates [path] readwrite. The path must not already exist. + + @param perms initial permissions for [path] + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val dev_null_out : unit -> ([> wronly], [> chr]) make +(** [dev_null_out ()] is "/dev/null" opened for writing *) + +val dev_null_in : unit -> ([> rdonly], [> chr]) make +(** [dev_null_in ()] is "/dev/null" opened for reading *) + +val dev_zero : unit -> ([> rdonly], [> chr]) make +(** [dev_zero ()] is "/dev/zero" opened for reading *) + +val shutdown_recv : ([< readable], [< sock]) make -> unit +(** [shutdown_recv t] shuts down receiving on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_send : ([< writable], [< sock]) make -> unit +(** [shutdown_send t] shuts down sending on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_all : ([< rdwr], [< sock]) make -> unit +(** [shutdown_all t] shuts down both receiving and sending on [t]. + + @see {!Unix.shutdown} + *) + +val ftruncate : ([< writable], [< truncatable]) make -> int64 -> unit +(** [ftruncate t size] sets the size of the regular file [t] to [size]. + + @see {!Unix.ftruncate} + *) + +val lseek : (_, [< seekable]) make -> int64 -> Unix.seek_command -> int64 +(** [lseek t off whence] sets the position of [t] to [off] with origin specified by [whence]. + + @see {!Unix.lseek} +*) + +val read : ([< readable], _) make -> bytes -> int -> int -> int +(** [read t buf off len] + @see {!Unix.read} + *) + +val single_write_substring : + ([< writable], _) make -> string -> int -> int -> int +(** [single_write_substring t buf off len] + + @see {!Unix.single_write_substring} +*) + +val set_nonblock : (_, [< espipe]) make -> unit +(** [set_nonblock t]. + + Only pipes, FIFOs and sockets are guaranteed to not block when this flag is set. + Although it is possible to set regular files and block devices as non-blocking, they currently still block + (although according to the manpage this may change in the future) + + @see {!Unix.set_nonblock} + *) + +val clear_nonblock : _ t -> unit +(** [clear_nonblock t]. + + We do not restrict clearing the non-blocking flag: that is just reverting back to default behaviour. + + @see {!Unix.clear_nonblock} + *) + +(** {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 +*) + +(**/**) + +module For_test : sig + val unsafe_fd_exn : _ t -> Unix.file_descr +end diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index 60619b2c1aa..505852753bb 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,6 +1,6 @@ (tests (package xapi-fdcaps) - (names test_safefd test_properties) + (names test_safefd test_properties test_operations) (libraries xapi_fdcaps alcotest fmt) ) diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml new file mode 100644 index 00000000000..f3c22f36619 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -0,0 +1,262 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps +open Properties +open Operations +open Syntax + +let b = Bytes.make 256 'x' + +let read_fd fd = + let (_ : int) = read fd b 0 (Bytes.length b) in + () + +let check_unsafe_raises ?(exn = Unix.EBADF) name t op = + (* if we bypass the type safety then we should get an error at runtime, + but only when the capability is 'no', not when it is 'removed' + *) + let fd = For_test.unsafe_fd_exn t in + let msg = Printf.sprintf "%s when <%s: no; ..>" name name in + let exn = Unix.Unix_error (exn, name, "") in + Alcotest.check_raises msg exn @@ fun () -> op fd + +let error_read_fd (t : ([< wronly], _) make) = + let@ fd = check_unsafe_raises "read" t in + let (_ : int) = Unix.read fd b 0 (Bytes.length b) in + () + +let str = "test" + +let write_fd fd = + let (_ : int) = single_write_substring fd str 0 (String.length str) in + () + +let error_write_fd (t : ([< rdonly], _) make) = + let@ fd = check_unsafe_raises "single_write" t in + let (_ : int) = Unix.single_write_substring fd str 0 (String.length str) in + () + +let test_ro fd = read_fd fd ; error_write_fd fd + +let test_wo fd = write_fd fd ; error_read_fd fd + +let test_lseek t = + let actual = lseek t 0L Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"starting position" ~expected:0L ~actual ; + let expected = 17L in + let actual = lseek t expected Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"jump1 position" ~expected ~actual ; + let actual = lseek t 3L Unix.SEEK_CUR in + Alcotest.(check' int64) ~msg:"jump2 position" ~expected:20L ~actual + +let error_lseek (t : (_, [< espipe]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ESPIPE "lseek" t in + let (_ : int) = Unix.lseek fd 0 Unix.SEEK_CUR in + () + +let test_ftruncate t = + let expected = 4000L in + ftruncate t expected ; + let actual = lseek t 0L Unix.SEEK_END in + Alcotest.(check' int64) ~msg:"size after ftruncate" ~expected ~actual + +type not_truncate = [blk | chr | dir | lnk | fifo | sock] + +let error_ftruncate (t : (_, [< not_truncate]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.EINVAL "ftruncate" t in + Unix.LargeFile.ftruncate fd 4000L + +type not_sock = [reg | blk | chr | dir | lnk | fifo] + +let error_shutdown (t : (_, [< not_sock]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ENOTSOCK "shutdown" t in + Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + +let test_fd2 make ops = + ops + |> List.map @@ fun (name, op1, op2) -> + let test () = + let@ fd1, fd2 = with_fd2 @@ make () in + pp Fmt.stdout fd1 ; + dump Fmt.stdout fd1 ; + (* the 2 operations may depend on each-other, e.g. write and read on a pipe, so must be part of same testcase *) + set_nonblock fd1 ; + set_nonblock fd2 ; + op2 fd2 ; + op1 fd1 ; + clear_nonblock fd1 ; + clear_nonblock fd2 + in + Alcotest.(test_case name `Quick) test + +let test_fd with_make ops = + ops + |> List.map @@ fun (name, op) -> + let test () = + let@ fd = with_make () in + op fd + in + Alcotest.(test_case name `Quick) test + +let test_pipe = + test_fd2 pipe + [ + ("wo,ro", test_ro, test_wo) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ; ("error_shutdown", error_shutdown, error_shutdown) + ] + +let test_sock = + let make () = socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + test_fd2 make + [ + ("read,write", read_fd, write_fd) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ] + +let with_fd fd f = pp Fmt.stdout fd ; dump Fmt.stdout fd ; with_fd fd f + +let with_tempfile () f = + let@ name, fd = with_tempfile () in + Fmt.pf Fmt.stdout "%s: %a@." name pp fd ; + f (name, fd) + +let test_single make f () = + let@ t = with_fd @@ make () in + error_shutdown t ; f t + +let test_safe_close () = + let@ t = with_fd @@ dev_null_in () in + close t ; close t + +let test_regular = + let with_make () f = + let@ _name, out = with_tempfile () in + f out + in + test_fd with_make + [ + ("wo", test_wo) + ; ("lseek", test_lseek) + ; ("ftruncate", test_ftruncate) + ; ("error_shutdown", error_shutdown) + ] + +let test_sock_shutdown_r () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + shutdown_recv fd1 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown of other end" exn in + write_fd fd2 + +let test_sock_shutdown_w () = + let@ _fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_send fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + +let test_sock_shutdown_all () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_all fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let () = + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd1 + +let test_block sector_size = + let with_make () f = + let@ name, fd = with_tempfile () in + ftruncate fd 8192L ; + let run () = + try + let@ _blkname, fd = with_temp_blk ~sector_size name in + f fd + with Failure _ -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Failure "with_temp_blk") bt + in + if Unix.geteuid () = 0 then + run () + else + Alcotest.check_raises "non-root fails to create blockdevice" + (Failure "with_temp_blk") run + in + test_fd with_make + [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] + +let test_block_nest = + let with_make () f = + if Unix.geteuid () <> 0 then + Alcotest.skip () ; + let@ name, fd = with_tempfile () in + ftruncate fd 8192L ; + let@ blkname, _fd = with_temp_blk ~sector_size:4096 name in + let@ _blkname, fd = with_temp_blk ~sector_size:512 blkname in + f fd + in + test_fd with_make + [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] + +let test_creat () = + let name = Filename.temp_file __MODULE__ (Unix.getpid () |> string_of_int) in + Unix.unlink name ; + let@ fd1 = with_fd @@ creat name [] 0o600 in + pp Fmt.stdout fd1 ; + read_fd fd1 ; + write_fd fd1 ; + let@ fd2 = with_fd @@ openfile_rw `reg name [] in + pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 + +let tests = + Alcotest. + [ + test_case "/dev/null in" `Quick @@ test_single dev_null_in test_ro + ; test_case "/dev/null out" `Quick @@ test_single dev_null_out test_wo + ; test_case "/dev/zero" `Quick @@ test_single dev_zero test_ro + ; test_case "safe close" `Quick test_safe_close + ; test_case "socket shutdown read" `Quick test_sock_shutdown_r + ; test_case "socket shutdown write" `Quick test_sock_shutdown_w + ; test_case "socket shutdown both" `Quick test_sock_shutdown_all + ; test_case "create" `Quick test_creat + ] + +(* this must be the last test *) +let test_no_leaks () = + Gc.full_major () ; + Alcotest.(check' int) + ~msg:"Check for no FD leaks" ~expected:0 ~actual:(Safefd.leaked ()) + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("pipe", test_pipe) + ; ("socket", test_sock) + ; ("regular", test_regular) + ; ("block 512", test_block 512) + ; ("block 4k", test_block 4096) + ; ("block 512 on 4k", test_block_nest) + ; ("xapi_fdcaps", tests) + ; ("no fd leaks", [Alcotest.test_case "no leaks" `Quick test_no_leaks]) + ] diff --git a/lib/xapi-fdcaps/test/test_operations.mli b/lib/xapi-fdcaps/test/test_operations.mli new file mode 100644 index 00000000000..e69de29bb2d From b1c757b4c01ecd0e6d3a2436efe526812cb8fa3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 13:44:26 +0000 Subject: [PATCH 09/22] CP-47001: [xapi-fdcaps]: wrap more Unix operations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 79 +++++++++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 57 ++++++++++++++++++ lib/xapi-fdcaps/properties.ml | 18 ++++++ lib/xapi-fdcaps/properties.mli | 3 + lib/xapi-fdcaps/test/test_operations.ml | 41 +++++++++++++ 5 files changed, 198 insertions(+) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 12e74d60681..7f7c9067e7a 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -56,6 +56,8 @@ let pp ppf = let close t = Safefd.idempotent_close_exn t.fd +let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) + let with_fd t f = let finally () = close t in Fun.protect ~finally (fun () -> f t) @@ -107,6 +109,14 @@ let creat path flags perm = (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags) perm +let kind_of_fd fd = of_unix_kind Unix.LargeFile.((fstat fd).st_kind) + +let stdin = make_ro_exn (kind_of_fd Unix.stdin) Unix.stdin + +let stdout = make_wo_exn (kind_of_fd Unix.stdout) Unix.stdout + +let stderr = make_wo_exn (kind_of_fd Unix.stderr) Unix.stderr + let dev_null_out () = openfile_wo `chr "/dev/null" [] let dev_null_in () = openfile_ro `chr "/dev/null" [] @@ -122,6 +132,9 @@ let shutdown_send t = let shutdown_all t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL +let setsockopt_float t opt value = + Unix.setsockopt_float (Safefd.unsafe_to_file_descr_exn t.fd) opt value + let ftruncate t size = match t.custom_ftruncate with | None -> @@ -138,6 +151,18 @@ let read t buf off len = let single_write_substring t buf off len = Unix.single_write_substring (Safefd.unsafe_to_file_descr_exn t.fd) buf off len +let fstat t = Unix.LargeFile.fstat (Safefd.unsafe_to_file_descr_exn t.fd) + +let dup t = + { + t with + fd= + t.fd + |> Safefd.unsafe_to_file_descr_exn + |> Unix.dup + |> Safefd.of_file_descr + } + let set_nonblock t = Unix.set_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) let clear_nonblock t = Unix.clear_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) @@ -200,6 +225,60 @@ let with_temp_blk ?(sector_size = 512) name f = let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +let repeat_read op fd buf off len = + let rec loop consumed = + let off = off + consumed and len = len - consumed in + if len = 0 then + consumed (* we filled the buffer *) + else + match op fd buf off len with + | 0 (* EOF *) + | (exception + Unix.( + Unix_error + ((ECONNRESET | ENOTCONN | EAGAIN | EWOULDBLOCK | EINTR), _, _)) + ) (* connection error or non-blocking socket *) -> + consumed + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (consumed + n) + in + loop 0 + +let repeat_write op fd buf off len = + let rec loop written = + let off = off + written and len = len - written in + if len = 0 then + written (* we've written the entire buffer *) + else + match op fd buf off len with + | 0 + (* should never happen, but we cannot retry now or we'd enter an infinite loop *) + | (exception + Unix.( + Unix_error + ( ( ECONNRESET + | EPIPE + | EINTR + | ENETDOWN + | ENETUNREACH + | EAGAIN + | EWOULDBLOCK ) + , _ + , _ + )) + ) (* connection error or nonblocking socket *) -> + written + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (written + n) + in + loop 0 + module For_test = struct let unsafe_fd_exn t = Safefd.unsafe_to_file_descr_exn t.fd end diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index e320c681648..ee4a9f363f0 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -62,11 +62,26 @@ end (** {1 {!mod:Unix} wrappers} *) +val stdin : ([> rdonly], kind) make +(** [stdin] is a readonly file descriptor of unknown kind *) + +val stdout : ([> wronly], kind) make +(** [stdout] is a writeonly file descriptor of unknown kind *) + +val stderr : ([> wronly], kind) make +(** [stderr] is a writeonly file descriptor of unknown kind *) + val close : _ t -> unit (** [close t] closes t. Doesn't raise an exception if it is already closed. Other errors from the underlying {!val:Unix.close} are propagated. *) +val fsync : _ t -> unit +(** [fsync t] flushes [t] buffer to disk. + + Note that the file doesn't necessarily have to be writable, e.g. you can fsync a readonly open directory. + *) + val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make (** [pipe ()] creates an unnamed pipe. @see {!val:Unix.pipe} @@ -173,6 +188,12 @@ val single_write_substring : @see {!Unix.single_write_substring} *) +val fstat : _ t -> Unix.LargeFile.stats +(** [fstat t] is {!val:Unix.LargeFile.fstat} *) + +val dup : 'a t -> 'a t +(** [dup t] is {!val:Unix.dup} on [t]. *) + val set_nonblock : (_, [< espipe]) make -> unit (** [set_nonblock t]. @@ -191,6 +212,10 @@ val clear_nonblock : _ t -> unit @see {!Unix.clear_nonblock} *) +val setsockopt_float : + (_, [< sock]) make -> Unix.socket_float_option -> float -> unit +(** [set_sockopt_float t opt val] sets the socket option [opt] to [val] for [t]. *) + (** {1 Temporary files} *) val with_tempfile : @@ -209,6 +234,38 @@ val with_temp_blk : @param sector_size between 512 and 4096 *) +(** {1 Operation wrappers} + + The low-level {!val:read} and {!val:single_write_substring} can raise different exceptions + to mean end-of-file/disconnected depending on the file's kind. + + If you want to consider disconnectins as end-of-file then use these wrappers. + *) + +(** a buffered operation on a file descriptors. + + @see {!val:read} and {!val:single_write_substring} + *) +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +val repeat_read : ('a, bytes) operation -> ('a, bytes) operation +(** [repeat_read op buf off len] repeats [op] on the supplied buffer until EOF or a connection error is encountered. + The following connection errors are treated as EOF and are not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.ENOTCONN}. + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if EOF was encountered. +*) + +val repeat_write : ('a, string) operation -> ('a, string) operation +(** [repeat_write op buf off len] repeats [op] on the supplied buffer until a connection error is encountered or the entire buffer is written. + The following are treated as connection errors and not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.EPIPE}, {!val:Unix.ENETDOWN}, {!val:Unix.ENETUNREACH} + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if we were not able to complete the write due to a connection error. +*) + (**/**) module For_test : sig diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml index 9e359a9b471..d26194cfeb9 100644 --- a/lib/xapi-fdcaps/properties.ml +++ b/lib/xapi-fdcaps/properties.ml @@ -59,6 +59,24 @@ let to_unix_kind = | #sock -> S_SOCK +let of_unix_kind = + let open Unix in + function + | S_REG -> + `reg + | S_BLK -> + `blk + | S_CHR -> + `chr + | S_DIR -> + `dir + | S_LNK -> + `lnk + | S_FIFO -> + `fifo + | S_SOCK -> + `sock + let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt let pp fmt = diff --git a/lib/xapi-fdcaps/properties.mli b/lib/xapi-fdcaps/properties.mli index 0afc529c56a..6b51a3ab7a7 100644 --- a/lib/xapi-fdcaps/properties.mli +++ b/lib/xapi-fdcaps/properties.mli @@ -161,6 +161,9 @@ val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option val to_unix_kind : kind -> Unix.file_kind (** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) +val of_unix_kind : Unix.file_kind -> kind +(** [of_unix_kind kind] converts the {!type:Unix.file_kind} to {!type:kind}. *) + (** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) type espipe = [fifo | sock] diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml index f3c22f36619..fa60e5f6682 100644 --- a/lib/xapi-fdcaps/test/test_operations.ml +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -227,6 +227,45 @@ let test_creat () = let@ fd2 = with_fd @@ openfile_rw `reg name [] in pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 +let test_repeat_read () = + let buf = String.init 255 Char.chr in + let read _ dst off len = + let available = String.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string buf off dst off len ; + len + in + let dst = Bytes.make 300 '_' in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_read read placeholder dst 0 (Bytes.length dst) in + Alcotest.(check' int) ~msg:"amount read" ~actual ~expected:(String.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string dst 0 actual) + ~expected:buf + +let test_repeat_write () = + let buf = Bytes.make 255 '_' in + let write _ src off len = + let available = Bytes.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string src off buf off len ; + len + in + let src = String.init 255 Char.chr in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_write write placeholder src 0 (String.length src) in + Alcotest.(check' int) + ~msg:"amount written" ~actual ~expected:(Bytes.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string buf 0 actual) + ~expected:src + let tests = Alcotest. [ @@ -238,6 +277,8 @@ let tests = ; test_case "socket shutdown write" `Quick test_sock_shutdown_w ; test_case "socket shutdown both" `Quick test_sock_shutdown_all ; test_case "create" `Quick test_creat + ; test_case "repeat_read" `Quick test_repeat_read + ; test_case "repeat_write" `Quick test_repeat_write ] (* this must be the last test *) From 4da756c809ffee1586121c1de69555e57065f215 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 13:58:26 +0000 Subject: [PATCH 10/22] CP-47001: [xapi-fdcaps] runtime tests for read-write properties MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 31 +++++++++++++++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 23 +++++++++++++++++++++++ 2 files changed, 54 insertions(+) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 7f7c9067e7a..bce25cdcd03 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -58,6 +58,29 @@ let close t = Safefd.idempotent_close_exn t.fd let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) +let as_readable_opt t = + match as_readable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_writable_opt t = + match as_writable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_spipe_opt t = + match + (Properties.as_kind_opt `sock t.props, Properties.as_kind_opt `fifo t.props) + with + | Some props, _ | _, Some props -> + Some {t with props} + | None, None -> + None + let with_fd t f = let finally () = close t in Fun.protect ~finally (fun () -> f t) @@ -129,6 +152,14 @@ let shutdown_recv t = let shutdown_send t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND +let as_readonly_socket t = + shutdown_send t ; + {t with props= Properties.make `rdonly `sock} + +let as_writeonly_socket t = + shutdown_recv t ; + {t with props= Properties.make `wronly `sock} + let shutdown_all t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index ee4a9f363f0..6097f8cddf5 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -45,6 +45,19 @@ val setup : unit -> unit By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. *) +(** {1 Runtime property tests} *) + +val as_readable_opt : + (([< rw] as 'a), 'b) make -> ([> readable], 'b) make option +(** [as_readable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_writable_opt : + (([< rw] as 'a), 'b) make -> ([> writable], 'b) make option +(** [as_writable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_spipe_opt : ('a, [< kind]) make -> ('a, [> espipe]) make option +(** [as_spipe_opt t] returns [Some t] when [t] is a socket or pipe, and [None] otherwise. *) + (** {1 With resource wrappers} *) val with_fd : 'a t -> ('a t -> 'b) -> 'b @@ -158,6 +171,16 @@ val shutdown_send : ([< writable], [< sock]) make -> unit @see {!Unix.shutdown} *) +val as_readonly_socket : + ([< readable], [< sock]) make -> ([> rdonly], [> sock]) make +(** [as_readonly_socket t] calls {!val:shutdown_send} and returns a readonly socket, + if it was originally readable. *) + +val as_writeonly_socket : + ([< writable], [< sock]) make -> ([> wronly], [> sock]) make +(** [as_writeonly_socket t] calls {!val:shutdown_recv} and returns a writeonly socket, + if it was originally readable. *) + val shutdown_all : ([< rdwr], [< sock]) make -> unit (** [shutdown_all t] shuts down both receiving and sending on [t]. From 43026be18eb7e311bda89e23f545d82a1d94a9bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 13:58:50 +0000 Subject: [PATCH 11/22] CP-47001: [xapi-fdcaps-test]: add observations module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It can be used to wrap read or write operations andobserve the data that is transferred, and elapsed time. It also provides 2 functions that create a file of a given kind. We only test UNIX sockets, because socketpair doesn't support TCP sockets on Linux. Signed-off-by: Edwin Török --- lib/xapi-fd-test/dune | 5 +- lib/xapi-fd-test/observations.ml | 307 +++++++++++++++++++++ lib/xapi-fd-test/observations.mli | 202 ++++++++++++++ lib/xapi-fd-test/test/dune | 2 +- lib/xapi-fd-test/test/test_xapi_fd_test.ml | 115 ++++++++ 5 files changed, 629 insertions(+), 2 deletions(-) create mode 100644 lib/xapi-fd-test/observations.ml create mode 100644 lib/xapi-fd-test/observations.mli diff --git a/lib/xapi-fd-test/dune b/lib/xapi-fd-test/dune index b2a0d2fe007..4ae4d8d51b2 100644 --- a/lib/xapi-fd-test/dune +++ b/lib/xapi-fd-test/dune @@ -2,5 +2,8 @@ (library (public_name xapi-fd-test) (name xapi_fd_test) - (libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os) + (libraries (re_export xapi-fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) ) diff --git a/lib/xapi-fd-test/observations.ml b/lib/xapi-fd-test/observations.ml new file mode 100644 index 00000000000..32213b6de98 --- /dev/null +++ b/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/lib/xapi-fd-test/observations.mli b/lib/xapi-fd-test/observations.mli new file mode 100644 index 00000000000..2e4ecb6b7d0 --- /dev/null +++ b/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/lib/xapi-fd-test/test/dune b/lib/xapi-fd-test/test/dune index 10b800a0290..ecc23b141b3 100644 --- a/lib/xapi-fd-test/test/dune +++ b/lib/xapi-fd-test/test/dune @@ -2,5 +2,5 @@ (test (package xapi-fd-test) (name test_xapi_fd_test) - (libraries xapi_fd_test alcotest) + (libraries xapi_fd_test alcotest fmt mtime.clock.os) ) diff --git a/lib/xapi-fd-test/test/test_xapi_fd_test.ml b/lib/xapi-fd-test/test/test_xapi_fd_test.ml index e69de29bb2d..b6ae12eb035 100644 --- a/lib/xapi-fd-test/test/test_xapi_fd_test.ml +++ b/lib/xapi-fd-test/test/test_xapi_fd_test.ml @@ -0,0 +1,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 + ] + ) + ] From 908f5a021d0ecc133232120f1e65449a4d6de735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 17:05:01 +0000 Subject: [PATCH 12/22] CP-47001: [xapi-fdcaps-test]: add generate module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fd-test/generate.ml | 138 ++++++++++++++++++++++++++++++++++ lib/xapi-fd-test/generate.mli | 87 +++++++++++++++++++++ 2 files changed, 225 insertions(+) create mode 100644 lib/xapi-fd-test/generate.ml create mode 100644 lib/xapi-fd-test/generate.mli diff --git a/lib/xapi-fd-test/generate.ml b/lib/xapi-fd-test/generate.ml new file mode 100644 index 00000000000..b3d28b15c4d --- /dev/null +++ b/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/lib/xapi-fd-test/generate.mli b/lib/xapi-fd-test/generate.mli new file mode 100644 index 00000000000..6aba67c7a6d --- /dev/null +++ b/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 +*) From 78ec02fa44def47f9129da2f156e3e7819b6b362 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 17:27:25 +0000 Subject: [PATCH 13/22] CP-47001: [unixext-test]: add quickcheck-style test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Uses 'xapi_fd_test'. Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/test/dune | 13 ++ .../lib/xapi-stdext-unix/test/generate.mli | 0 .../lib/xapi-stdext-unix/test/unixext_test.ml | 163 ++++++++++++++++++ .../xapi-stdext-unix/test/unixext_test.mli | 0 4 files changed, 176 insertions(+) create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/generate.mli create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli 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..d1d467168e9 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -0,0 +1,163 @@ +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 tests = [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 From de2613e71c66ac76559ddec9a73af48db1a503c5 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Tue, 14 Feb 2023 13:38:31 +0000 Subject: [PATCH 14/22] CP-47001: Add unit tests for threadext MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Steven Woods Signed-off-by: Edwin Török --- dune-project | 1 + .../xapi-stdext/lib/xapi-stdext-threads/dune | 6 ++++ .../lib/xapi-stdext-threads/threadext_test.ml | 35 +++++++++++++++++++ .../xapi-stdext-threads/threadext_test.mli | 0 xapi-stdext-threads.opam | 1 + 5 files changed, 43 insertions(+) create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli diff --git a/dune-project b/dune-project index 44b3b3c6722..5c037744405 100644 --- a/dune-project +++ b/dune-project @@ -336,6 +336,7 @@ base-unix (odoc :with-doc) (xapi-stdext-pervasives (= :version)) + (mtime :with-test) ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index fe2cc6dd85a..a3b4d9f8609 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -1,8 +1,14 @@ (library (public_name xapi-stdext-threads) (name xapi_stdext_threads) + (modules :standard \ threadext_test) (libraries threads.posix 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_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/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 09449f30273..e6ad1798938 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -13,6 +13,7 @@ depends: [ "base-unix" "odoc" {with-doc} "xapi-stdext-pervasives" {= version} + "mtime" {with-test} ] build: [ ["dune" "subst"] {dev} From 8ef9fa57a0555df36f92a949a5d4742738c82128 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 30 Jan 2024 22:34:43 +0000 Subject: [PATCH 15/22] CP-47001: [unixext-test]: add test for Unixext.proxy MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/test/unixext_test.ml | 34 ++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) 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 index d1d467168e9..2acad9396fd 100644 --- 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 @@ -155,7 +155,39 @@ let test_time_limited_read = in true -let tests = [test_time_limited_write; test_time_limited_read] +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 *) From 801bb4f5745efd64f34bd59a8cc5a661dcec77a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 09:02:15 +0000 Subject: [PATCH 16/22] Unix.time_limited_write: fix timeout behaviour on >64KiB writes/reads MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `Unix.write` would internally loop until the desired number of bytes are sent, or `EAGAIN`/`EWOULDBLOCK`/another error is reached. It cannot check for timeouts because it is not aware that we'd want one. For pipes and sockets in non-blocking mode this wouldn't be a problem, but this function is often called with block devices too. However according to `pselect(3p)` it is a no-op on regular files: "File descriptors associated with regular files shall always select true for ready to read, ready to write, and error conditions." And the behaviour on block devices is left unspecified by POSIX, and `select(2)` on Linux doesn't document the behaviour either: "The pselect() and select() functions shall support regular files, terminal and pseudo‐terminal devices, STREAMS‐based files, FIFOs, pipes, and sockets. The behavior of pselect() and select() on file descriptors that refer to other types of file is unspecified" Although timeouts for a completely stuck block device cannot be implemented, we can still implement timeouts for a *slow* block device. Use `Unix.single_{write,read}` instead which gives full control of the iteration to the caller. The only way to interrupt stuck IO on a block device or regular file would be to use a separate process and `SIGKILL` it after a timeout (this is what `block_device_io` in XAPI does). These approaches do not work: * `alarm` or `setitimer` would only interrupt one thread in a multi-threaded program. * `pthread_kill` can be used to send a signal to a particular thread, but that requires `EINTR` behaviour on syscalls to be enabled * XAPI expects `SA_RESTART` semantics from syscalls, and would fail an assertion if it ever sees `EINTR` in some paths, so although the syscall *would* get interrupted, it'd also immediately resume without giving the caller a chance to check for timeouts * even if it'd work there are no bindings to `pthread_kill` in OCaml Signed-off-by: Edwin Török --- ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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..e6d1f99ac22 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -562,11 +562,11 @@ 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. *) From 319b82b6fa72e018bf68d28b82c6a1f166a59b29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 11:07:09 +0000 Subject: [PATCH 17/22] Unix.time_limited_{read,write}: replace select with Polly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 'select' has a hardcoded limit of 1024 file descriptors. Signed-off-by: Edwin Török --- dune-project | 1 + .../xapi-stdext/lib/xapi-stdext-unix/dune | 2 + .../lib/xapi-stdext-unix/unixext.ml | 105 ++++++++++++------ xapi-stdext-unix.opam | 3 +- xapi-stdext-unix.opam.template | 2 +- 5 files changed, 79 insertions(+), 34 deletions(-) diff --git a/dune-project b/dune-project index 5c037744405..0c9c6712bac 100644 --- a/dune-project +++ b/dune-project @@ -350,6 +350,7 @@ (odoc :with-doc) xapi-backtrace (xapi-stdext-pervasives (= :version)) + polly ) ) 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/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index e6d1f99ac22..42df0b510b9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -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] *) @@ -528,32 +533,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 @@ -573,29 +615,28 @@ let time_limited_write_substring filedesc length data target_response_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 diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index b067d6d030b..36df8e943d8 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -14,6 +14,7 @@ depends: [ "odoc" {with-doc} "xapi-backtrace" "xapi-stdext-pervasives" {= version} + "polly" ] build: [ ["dune" "subst"] {dev} @@ -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" ] From 8736e5d9f65ac4d7eeee3225cf6824ccd7bf669e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 28 Nov 2023 17:17:46 +0000 Subject: [PATCH 18/22] add Unixext.time_limited_single_read MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It is too easy to misuse Unixext.time_limited_read because that one takesan absolute timestamp as parameter, not a relative one. Introduce a new function that takes a relative time as parameter, and doesn't loop. Signed-off-by: Edwin Török --- .../xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 14 ++++++++++++++ .../xapi-stdext/lib/xapi-stdext-unix/unixext.mli | 3 +++ 2 files changed, 17 insertions(+) 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 42df0b510b9..3c6bada784c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -644,6 +644,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 From b0935423d763f13f895aee33c44b4d6c6684a413 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 15:00:42 +0000 Subject: [PATCH 19/22] CP-32622: replace select with Thread.delay MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 3c6bada784c..1b58ff8b3f1 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 From bcae6f5eb6d8eb88db96475cd26cecdbd8a7a34c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 15:39:40 +0000 Subject: [PATCH 20/22] CP-32622: Delay: replace select with time_limited_read MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- dune-project | 1 + ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune | 1 + .../xapi-stdext/lib/xapi-stdext-threads/threadext.ml | 10 +++++++--- xapi-stdext-threads.opam | 1 + 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/dune-project b/dune-project index 0c9c6712bac..a43ca18d1a7 100644 --- a/dune-project +++ b/dune-project @@ -337,6 +337,7 @@ (odoc :with-doc) (xapi-stdext-pervasives (= :version)) (mtime :with-test) + (xapi-stdext-unix (= :version)) ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index a3b4d9f8609..4db49ea52e2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -5,6 +5,7 @@ (libraries threads.posix unix + xapi-stdext-unix xapi-stdext-pervasives) ) (test 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/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index e6ad1798938..8de2f45c03e 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -14,6 +14,7 @@ depends: [ "odoc" {with-doc} "xapi-stdext-pervasives" {= version} "mtime" {with-test} + "xapi-stdext-unix" {= version} ] build: [ ["dune" "subst"] {dev} From 1c374c2ffcc63026810e1552f1dc5ff94fc6fe61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 26 Jan 2024 15:11:47 +0000 Subject: [PATCH 21/22] CP-32622: replace select in proxy with polly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/unixext.ml | 42 ++++++++++++------- 1 file changed, 28 insertions(+), 14 deletions(-) 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 1b58ff8b3f1..160cfe46b67 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -434,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) -> From 3f9472c98420403463930790d1c3ddb7cfcc8c2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 15 Apr 2024 10:45:01 +0100 Subject: [PATCH 22/22] CP-32622: move new libraries to proper subdir MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/dune | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/dune | 0 .../libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.ml | 0 .../libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/dune | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/dune | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/properties.t | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.ml | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.mli | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.ml | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.mli | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.ml | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.mli | 0 23 files changed, 0 insertions(+), 0 deletions(-) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/properties.t (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.mli (100%) diff --git a/lib/xapi-fd-test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune similarity index 100% rename from lib/xapi-fd-test/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune diff --git a/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml similarity index 100% rename from lib/xapi-fd-test/generate.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml diff --git a/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli similarity index 100% rename from lib/xapi-fd-test/generate.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli diff --git a/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml similarity index 100% rename from lib/xapi-fd-test/observations.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml diff --git a/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli similarity index 100% rename from lib/xapi-fd-test/observations.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli diff --git a/lib/xapi-fd-test/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune similarity index 100% rename from lib/xapi-fd-test/test/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune diff --git a/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 similarity index 100% rename from lib/xapi-fd-test/test/test_xapi_fd_test.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml diff --git a/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 similarity index 100% rename from lib/xapi-fd-test/test/test_xapi_fd_test.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli diff --git a/lib/xapi-fdcaps/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune similarity index 100% rename from lib/xapi-fdcaps/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune diff --git a/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml similarity index 100% rename from lib/xapi-fdcaps/operations.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml diff --git a/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli similarity index 100% rename from lib/xapi-fdcaps/operations.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli diff --git a/lib/xapi-fdcaps/properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml similarity index 100% rename from lib/xapi-fdcaps/properties.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml diff --git a/lib/xapi-fdcaps/properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli similarity index 100% rename from lib/xapi-fdcaps/properties.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli diff --git a/lib/xapi-fdcaps/safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml similarity index 100% rename from lib/xapi-fdcaps/safefd.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml diff --git a/lib/xapi-fdcaps/safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli similarity index 100% rename from lib/xapi-fdcaps/safefd.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli diff --git a/lib/xapi-fdcaps/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune similarity index 100% rename from lib/xapi-fdcaps/test/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune diff --git a/lib/xapi-fdcaps/test/properties.t b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t similarity index 100% rename from lib/xapi-fdcaps/test/properties.t rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_operations.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml diff --git a/lib/xapi-fdcaps/test/test_operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_operations.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli diff --git a/lib/xapi-fdcaps/test/test_properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_properties.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml diff --git a/lib/xapi-fdcaps/test/test_properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_properties.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli diff --git a/lib/xapi-fdcaps/test/test_safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_safefd.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml diff --git a/lib/xapi-fdcaps/test/test_safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_safefd.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli