diff --git a/.gitignore b/.gitignore index 352e9bbc008..967e463c15f 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 6cc67d2c004..efa6394047f 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 @@ -57,6 +62,7 @@ TEST_TIMEOUT=600 TEST_TIMEOUT2=1200 test: ulimit -S -t $(TEST_TIMEOUT); \ + ulimit -n 2048; \ (sleep $(TEST_TIMEOUT) && ps -ewwlyF --forest)& \ PSTREE_SLEEP_PID=$$!; \ trap "kill $${PSTREE_SLEEP_PID}" INT TERM EXIT; \ @@ -206,6 +212,7 @@ install: build doc sdk doc-json install -D -m 755 _build/install/default/bin/xcp-rrdd-iostat $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-iostat install -D -m 755 _build/install/default/bin/xcp-rrdd-squeezed $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-squeezed install -D -m 755 _build/install/default/bin/xcp-rrdd-xenpm $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-xenpm + install -D -m 755 _build/install/default/bin/xcp-rrdd-dcmi $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-dcmi install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins.xml install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins/stuff.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins/stuff.xml install -D -m 755 ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins $(DESTDIR)/etc/sysconfig/xcp-rrdd-plugins diff --git a/dune-project b/dune-project index cd4d286416c..6d0c661ee31 100644 --- a/dune-project +++ b/dune-project @@ -2,6 +2,8 @@ (formatting (enabled_for ocaml)) (using menhir 2.0) +(cram enable) +(implicit_transitive_deps false) (generate_opam_files true) (name "xapi") @@ -559,6 +561,8 @@ This package provides an Lwt compatible interface to the library.") base-unix (odoc :with-doc) (xapi-stdext-pervasives (= :version)) + (mtime :with-test) + (xapi-stdext-unix (= :version)) ) ) @@ -568,12 +572,19 @@ This package provides an Lwt compatible interface to the library.") (authors "Jonathan Ludlam") (depends (ocaml (>= 4.12.0)) + (alcotest :with-test) base-unix + (bisect_ppx :with-test) (fd-send-recv (>= 2.0.0)) + fmt + (mtime (and (>= 2.0.0) :with-test)) + (logs :with-test) + (qcheck-core (and (>= 0.21.2) :with-test)) (odoc :with-doc) xapi-backtrace unix-errno (xapi-stdext-pervasives (= :version)) + polly ) ) diff --git a/ocaml/database/dune b/ocaml/database/dune index 971385cb49e..08108ad6c55 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -41,6 +41,7 @@ xapi-datamodel xapi-log (re_export xapi-schema) + xapi-idl.updates xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index 01a413a512d..2547ae53182 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -271,7 +271,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : !Db_globs.permanent_master_failure_retry_interval ; Thread.delay !Db_globs.permanent_master_failure_retry_interval ; !Db_globs.restart_fn () - | e -> ( + | e -> error "Caught %s" (Printexc.to_string e) ; (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *) ( match !my_connection with @@ -322,9 +322,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : debug "%s: Sleep interrupted, retrying master connection now" __FUNCTION__ ; update_backoff_delay () ; - try open_secure_connection () with _ -> () - (* oh well, maybe nextime... *) - ) + D.log_and_ignore_exn open_secure_connection done ; !result diff --git a/ocaml/database/redo_log.ml b/ocaml/database/redo_log.ml index 3f20e32dfac..429646dcce7 100644 --- a/ocaml/database/redo_log.ml +++ b/ocaml/database/redo_log.ml @@ -642,7 +642,8 @@ let startup log = ) ; match !(log.device) with | None -> - D.info "Could not find block device" + D.info "Could not find block device" ; + broken log | Some device -> D.info "Using block device at %s" device ; (* Check that the block device exists *) diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 3d132e8ed76..160f444dd34 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -7,6 +7,7 @@ fd-send-recv rpclib.core rpclib.json + rpclib.xml uuid xapi-backtrace xapi-log diff --git a/ocaml/forkexecd/test/dune b/ocaml/forkexecd/test/dune index 657147a2c72..7ab49f0e214 100644 --- a/ocaml/forkexecd/test/dune +++ b/ocaml/forkexecd/test/dune @@ -1,7 +1,7 @@ (executable (modes exe) (name fe_test) - (libraries forkexec uuid xapi-stdext-unix)) + (libraries forkexec uuid xapi-stdext-unix fd-send-recv)) (rule (alias runtest) diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index 409d35e8233..bfbdd2b60b5 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -69,10 +69,10 @@ let t = [(Published, rel_stockholm, ""); (Deprecated, "24.19.0", "")] ~ty:String "fingerprint" ~default_value:(Some (VString "")) "Use fingerprint_sha256 instead" - ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha256" + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha256" ~default_value:(Some (VString "")) "The certificate's SHA256 fingerprint / hash" - ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha1" + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha1" ~default_value:(Some (VString "")) "The certificate's SHA1 fingerprint / hash" ] diff --git a/ocaml/idl/datamodel_cluster.ml b/ocaml/idl/datamodel_cluster.ml index 10c30bb540b..dba9b76c73b 100644 --- a/ocaml/idl/datamodel_cluster.ml +++ b/ocaml/idl/datamodel_cluster.ml @@ -169,6 +169,16 @@ let pool_resync = ~params:[(Ref _cluster, "self", "The cluster to resync")] ~lifecycle ~allowed_roles:_R_POOL_OP ~errs:[] () +let cstack_sync = + call ~name:"cstack_sync" + ~doc: + "Sync xapi db with the cluster stack synchronously, and generate alerts \ + as needed. Only happens on the coordinator as this is where the cluster \ + watcher performs updates." + ~params:[(Ref _cluster, "self", "The cluster to sync")] + ~hide_from_docs:true ~pool_internal:true ~lifecycle + ~allowed_roles:_R_POOL_OP ~errs:[] () + let t = create_obj ~name:_cluster ~descr:"Cluster-wide Cluster metadata" ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true @@ -245,5 +255,6 @@ let t = ; pool_force_destroy ; pool_destroy ; pool_resync + ; cstack_sync ] () diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index de22cf2e5ad..9afd7bd37c0 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -10,7 +10,7 @@ open Datamodel_roles to leave a gap for potential hotfixes needing to increment the schema version.*) let schema_major_vsn = 5 -let schema_minor_vsn = 779 +let schema_minor_vsn = 780 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 92316d8ee26..089986a5625 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -1,6 +1,6 @@ let prototyped_of_class = function | "VM_group" -> - Some "24.18.0-next" + Some "24.19.1" | "Observer" -> Some "23.14.0" | "VTPM" -> @@ -10,9 +10,9 @@ let prototyped_of_class = function let prototyped_of_field = function | "VM_group", "VMs" -> - Some "24.18.0-next" + Some "24.19.1" | "VM_group", "placement" -> - Some "24.18.0-next" + Some "24.19.1" | "Observer", "enabled" -> Some "23.14.0" | "Observer", "components" -> @@ -27,6 +27,10 @@ let prototyped_of_field = function Some "23.14.0" | "Repository", "gpgkey_path" -> Some "22.12.0" + | "Certificate", "fingerprint_sha1" -> + Some "24.19.1-next" + | "Certificate", "fingerprint_sha256" -> + Some "24.19.1-next" | "Cluster_host", "last_update_live" -> Some "24.3.0" | "Cluster_host", "live" -> @@ -62,7 +66,7 @@ let prototyped_of_field = function | "host", "last_software_update" -> Some "22.20.0" | "VM", "groups" -> - Some "24.18.0-next" + Some "24.19.1" | "VM", "pending_guidances_full" -> Some "24.10.0" | "VM", "pending_guidances_recommended" -> @@ -72,7 +76,7 @@ let prototyped_of_field = function | "VM", "actions__after_softreboot" -> Some "23.1.0" | "pool", "recommendations" -> - Some "24.18.0-next" + Some "24.19.1" | "pool", "update_sync_enabled" -> Some "23.18.0" | "pool", "update_sync_day" -> @@ -150,7 +154,7 @@ let prototyped_of_message = function | "VM", "restart_device_models" -> Some "23.30.0" | "VM", "set_groups" -> - Some "24.18.0-next" + Some "24.19.1" | "pool", "get_guest_secureboot_readiness" -> Some "24.17.0" | "pool", "set_ext_auth_max_threads" -> diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index c08c9671791..31011eec08d 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -112,6 +112,19 @@ let gen_non_record_type tys = t | ty :: t -> let alias = OU.alias_of_ty ty in + let accu = + match ty with + | DT.Enum (name, cs) -> + sprintf "let all_%s = [%s]" name + (cs + |> List.map fst + |> List.map OU.constructor_of + |> String.concat "; " + ) + :: accu + | _ -> + accu + in if List.mem_assoc alias overrides then aux (sprintf "type %s = %s\n%s\n" alias (OU.ocaml_of_ty ty) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index f2ee8fe4be2..4ba16fbfe1c 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "efdb1c7e536362523741ccdb7f33f797" +let last_known_schema_hash = "7885f7b085e4a5e32977a4b222030412" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 009e2ba7176..3276c2c08ff 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -16,5 +16,5 @@ (names test_date test_timer) (package clock) (modules test_date test_timer) - (libraries alcotest clock fmt mtime ptime qcheck-core qcheck-core.runner) + (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-core.runner) ) diff --git a/ocaml/libs/ezxenstore/core/dune b/ocaml/libs/ezxenstore/core/dune index b1b11e8b6a0..53e812032f7 100644 --- a/ocaml/libs/ezxenstore/core/dune +++ b/ocaml/libs/ezxenstore/core/dune @@ -6,6 +6,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/bufio_test.ml b/ocaml/libs/http-lib/bufio_test.ml new file mode 100644 index 00000000000..b35c55381de --- /dev/null +++ b/ocaml/libs/http-lib/bufio_test.ml @@ -0,0 +1,81 @@ +open QCheck2 +open Xapi_fd_test + +let print_timeout = string_of_float + +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 test_buf_io = + let timeouts = Generate.timeouts in + let gen = Gen.tup2 Generate.t timeouts + and print = Print.tup2 Generate.print print_timeout in + Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> + let timeout_span = Mtime.Span.of_float_ns (timeout *. 1e9) |> Option.get in + (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) + if behaviour.kind <> Unix.S_SOCK then + QCheck2.assume_fail () ; + (* we only support sockets for this function *) + 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 + let bio = Buf_io.of_fd fd in + let dt = Mtime_clock.counter () in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Buf_io.really_input_buf bio behaviour.size ~timeout + ) + 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 = !test_elapsed in + let timeout_extra = + Mtime.Span.(add (timeout_span :> Mtime.Span.t) @@ (500 * ms)) + in + if Mtime.Span.compare elapsed timeout_extra > 0 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %a > %.6f; %s" + Mtime.Span.pp elapsed 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 (Buf_io.Timeout, _)) -> + let elapsed = !test_elapsed in + if Mtime.Span.compare elapsed timeout_span < 0 then + Test.fail_reportf "Timed out earlier than requested: %a < %a" + Mtime.Span.pp elapsed Mtime.Span.pp timeout_span + | ( {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 () = + (* avoid SIGPIPE *) + let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in + QCheck_base_runner.run_tests_main [test_buf_io] diff --git a/ocaml/libs/http-lib/bufio_test.mli b/ocaml/libs/http-lib/bufio_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index 1bd9932703d..ee510d7fc42 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -3,11 +3,12 @@ (public_name http-lib) (modes best) (wrapped false) - (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server)) + (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test)) (preprocess (per_module ((pps ppx_deriving_rpc) Http))) (libraries astring base64 + fmt ipaddr mtime mtime.clock.os @@ -19,6 +20,7 @@ stunnel threads.posix uuid + uri xapi-backtrace xapi-consts.xapi_version xapi-idl.updates @@ -40,8 +42,10 @@ (libraries astring http_lib + ipaddr polly threads.posix + uri xapi-log xapi-stdext-pervasives xapi-stdext-threads @@ -57,10 +61,37 @@ (libraries alcotest dune-build-info + fmt http_lib ) ) +(test + (name bufio_test) + (package http-lib) + (modes (best exe)) + (modules bufio_test) + (libraries + fmt + mtime + mtime.clock + mtime.clock.os + rresult + http_lib + qcheck-core + qcheck-core.runner + xapi_fd_test + ) + ; 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:bufio_test.exe} -v -bt)) +) + (executable (modes exe) (name test_client) diff --git a/ocaml/libs/sexpr/test/dune b/ocaml/libs/sexpr/test/dune index aa62e13e4e0..78aa0ac6052 100644 --- a/ocaml/libs/sexpr/test/dune +++ b/ocaml/libs/sexpr/test/dune @@ -2,4 +2,4 @@ (name test_sexpr) (package sexpr) (modules test_sexpr) - (libraries sexpr astring rresult qcheck-core alcotest threads)) + (libraries sexpr astring rresult qcheck-core alcotest threads.posix)) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 7003efe2d9f..8d319b4b80d 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -403,7 +403,7 @@ let rec retry f = function try f () with Stunnel_initialisation_failed -> (* Leave a few seconds between each attempt *) - ignore (Unix.select [] [] [] 3.) ; + Thread.delay 3. ; retry f (n - 1) ) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index e30fee8c140..8c53962c579 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -1,7 +1,7 @@ (library (name tracing) (modules tracing) - (libraries re uri xapi-log xapi-stdext-threads) + (libraries re uri xapi-log xapi-stdext-threads threads.posix) (public_name xapi-tracing)) (library @@ -15,7 +15,10 @@ ptime.clock.os rpclib.core rpclib.json + result + rresult tracing + threads.posix uri xapi-log xapi-open-uri @@ -29,4 +32,4 @@ (name test_tracing) (modules test_tracing) (package xapi-tracing) - (libraries tracing alcotest uuid)) + (libraries tracing alcotest fmt uuid xapi-log)) 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/vhd/vhd_format_lwt_test/dune b/ocaml/libs/vhd/vhd_format_lwt_test/dune index c8ff604d921..d8ece640123 100644 --- a/ocaml/libs/vhd/vhd_format_lwt_test/dune +++ b/ocaml/libs/vhd/vhd_format_lwt_test/dune @@ -1,5 +1,5 @@ (test (name parse_test) (package vhd-format-lwt) - (libraries alcotest alcotest-lwt cstruct disk io-page lwt lwt.unix vhd-format + (libraries alcotest alcotest-lwt cstruct disk fmt io-page lwt lwt.unix vhd-format vhd_format_lwt)) diff --git a/ocaml/libs/xapi-inventory/lib/dune b/ocaml/libs/xapi-inventory/lib/dune index 7fb4aa7e40b..905b47bfceb 100644 --- a/ocaml/libs/xapi-inventory/lib/dune +++ b/ocaml/libs/xapi-inventory/lib/dune @@ -7,6 +7,6 @@ astring xapi-stdext-unix xapi-stdext-threads - threads + threads.posix ) ) diff --git a/ocaml/libs/xapi-rrd/lib/dune b/ocaml/libs/xapi-rrd/lib/dune index 00b4bedfc3d..2f90e3e2f45 100644 --- a/ocaml/libs/xapi-rrd/lib/dune +++ b/ocaml/libs/xapi-rrd/lib/dune @@ -6,6 +6,7 @@ (libraries bigarray rpclib.json + rpclib.core xmlm yojson ) diff --git a/ocaml/libs/xapi-rrd/lib_test/dune b/ocaml/libs/xapi-rrd/lib_test/dune index b565d445d49..7a66380a63e 100644 --- a/ocaml/libs/xapi-rrd/lib_test/dune +++ b/ocaml/libs/xapi-rrd/lib_test/dune @@ -9,6 +9,8 @@ unix xapi-rrd xapi-stdext-unix + rpclib.xml + xmlm ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune new file mode 100644 index 00000000000..146eadc9e0b --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune @@ -0,0 +1,8 @@ +; This will be used to test stdext itself, so do not depend on stdext here +(library + (name xapi_fd_test) + (libraries (re_export xapi-stdext-unix.fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml new file mode 100644 index 00000000000..b3d28b15c4d --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml @@ -0,0 +1,138 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps +open Operations +open Observations + +type t = { + size: int + ; delay_read: Delay.t option + ; delay_write: Delay.t option + ; kind: Unix.file_kind +} + +let make ~size ~delay_read ~delay_write kind = + {size; delay_read; delay_write; kind} + +open QCheck2 + +let file_kind = + ( Gen.oneofa Unix.[|S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK|] + , Print.contramap (Fmt.to_to_string Safefd.pp_kind) Print.string + ) + +(* also coincidentally the pipe buffer size on Linux *) +let ocaml_unix_buffer_size = 65536 + +let sizes = + Gen.oneofa + [| + 0 + ; 1 + ; 100 + ; 4096 + ; ocaml_unix_buffer_size - 1 + ; ocaml_unix_buffer_size + ; ocaml_unix_buffer_size + 1 + ; 2 * ocaml_unix_buffer_size + ; (10 * ocaml_unix_buffer_size) + 3 + |] + +(* some may exceed length of test, but that is what the timeout is for *) +let total_delays = Gen.oneofa [|0.001; 0.01; 0.1; 0.4|] + +let span_of_s s = s *. 1e9 |> Mtime.Span.of_float_ns |> Option.get + +(* keep these short *) +let timeouts = Gen.oneofa [|0.0; 0.001; 0.1; 0.3|] + +let delay_of_size total_delay size = + let open Gen in + let* every_bytes = if size = 0 then return 1 else 1 -- size in + let chunks = max 1 (size / every_bytes) in + let duration = total_delay /. float_of_int chunks |> span_of_s in + return @@ Some (Delay.v ~every_bytes ~duration) + +let t = + let open Gen in + (* order matters here for shrinking: shrink timeout first so that shrinking completes sooner! *) + let* total_delay = total_delays and* size = sizes and* kind = fst file_kind in + let* delay = delay_of_size total_delay size in + return @@ make ~delay_read:delay ~delay_write:delay ~size kind + +let print t = + (* to easily grep print on single line *) + let buf = Buffer.create 128 in + let fmt = Fmt.with_buffer buf in + Format.pp_set_geometry fmt ~max_indent:999 ~margin:1000 ; + Fmt.( + record ~sep:(any "; ") + [ + field "delay_read" (fun t -> t.delay_read) (option Delay.pp) + ; field "delay_write" (fun t -> t.delay_write) (option Delay.pp) + ; field "size" (fun t -> t.size) int + ; field "file_kind" (fun t -> (snd file_kind) t.kind) string + ] + ) + fmt t ; + Fmt.flush fmt () ; + Buffer.contents buf + +let run_ro t data ~f = + (* we can only implement delays on write, skip *) + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let write = + match t.delay_write with + | Some delay -> + Delay.apply_write cancel delay single_write_substring + | None -> + single_write_substring + in + observe_ro write ~f t.kind data + +let run_wo t ~f = + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let read = + match t.delay_read with + | Some delay -> + Delay.apply_read cancel delay read + | None -> + read + in + observe_wo read ~f t.kind ~size:t.size + +let run_rw t data ~f = + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let read = + match t.delay_read with + | Some delay -> + Delay.apply_read cancel delay read + | None -> + read + in + let write = + match t.delay_write with + | Some delay -> + Delay.apply_write cancel delay single_write_substring + | None -> + single_write_substring + in + observe_rw read write ~f t.kind ~size:t.size data diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli new file mode 100644 index 00000000000..6aba67c7a6d --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli @@ -0,0 +1,87 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +open Xapi_fdcaps +open Properties +open Operations +open Observations + +(** file descriptor behaviour specification *) +type t = { + size: int + ; delay_read: Delay.t option + ; delay_write: Delay.t option + ; kind: Unix.file_kind +} + +val timeouts : float QCheck2.Gen.t +(** [timeouts] is a generator for small timeouts *) + +val make : + size:int + -> delay_read:Delay.t option + -> delay_write:Delay.t option + -> Unix.file_kind + -> t +(** [make ~size ~delay_read ~delay_write kind] is a file descriptor test. + + @param size the size of the file, or the amount of data sent on a socket/pipe + @param delay_read whether to insert sleeps to trigger short reads + @param delay_write whether to insert sleeps to trigger short writes + @param kind the {!type:Unix.file_kind} of the file descriptor to create +*) + +val t : t QCheck2.Gen.t +(** [t] is a {!mod:QCheck2} generator for {!type:t}. + + This doesn't yet open any file descriptors (there'd be too many leaks and we'd run out), + that is done by {!val:run} + + Follows the naming convention to name generators after the type they generate. +*) + +val print : t QCheck2.Print.t +(** [print] is a QCheck2 pretty printer for [t] *) + +val run_ro : + t + -> string + -> f:(([< readable > `rdonly], kind) make -> 'a) + -> (unit, [> wronly] observation option) observations * 'a or_exn +(** [run_ro t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as readonly. + + @returns observations about [f]'s actions the file descriptor +*) + +val run_wo : + t + -> f:(([< writable > `wronly], kind) make -> 'a) + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [run_wo t ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as writeonly. + + @returns observations about [f]'s actions on the file descriptor +*) + +val run_rw : + t + -> string + -> f:((rdwr, kind) make -> 'a) + -> ([> rdonly] observation option, [> wronly] observation option) observations + * 'a or_exn +(** [run_rw t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as read-write. + + @returns observations about [f]'s actions the file descriptor +*) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml new file mode 100644 index 00000000000..32213b6de98 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml @@ -0,0 +1,307 @@ +open Xapi_fdcaps +open Properties +open Operations +open Syntax + +let open_ro name = openfile_ro `reg name [] + +let open_wo name = openfile_wo `reg name [] + +let with_kind_ro kind f = + let with2 t = + let@ fd1, fd2 = with_fd2 t in + f fd1 (Some fd2) + in + match kind with + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f (as_readonly_socket fd1) (Some fd2) + | Unix.S_REG -> + let@ name, out = with_tempfile () in + let@ fd = with_fd @@ open_ro name in + f fd (Some out) + | Unix.S_FIFO -> + with2 (pipe ()) + | Unix.S_DIR -> + invalid_arg + "S_DIR" (* not supported, OCaml has separate dir_handle type *) + | Unix.S_LNK -> + invalid_arg "S_LNK" (* O_NOFOLLOW not bound in OCaml *) + | Unix.S_BLK -> + let@ name, out = with_tempfile ~size:512L () in + let@ blkname, _ = with_temp_blk name in + let@ fd = with_fd @@ open_ro blkname in + f fd (Some out) + | Unix.S_CHR -> + let@ fd = with_fd @@ dev_zero () in + f fd None + +let with_kind_wo kind f = + let with2 t = + let@ fd1, fd2 = with_fd2 t in + f fd2 (Some fd1) + in + match kind with + | Unix.S_REG -> + let@ name, _out = with_tempfile () in + let@ fd = with_fd @@ open_wo name in + let@ fd_ro = with_fd @@ open_ro name in + f fd (Some fd_ro) + | Unix.S_FIFO -> + with2 @@ pipe () + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f (as_writeonly_socket fd2) (Some fd1) + | Unix.S_DIR -> + invalid_arg + "S_DIR" (* not supported, OCaml has separate dir_handle type *) + | Unix.S_LNK -> + invalid_arg "S_LNK" (* O_NOFOLLOW not bound in OCaml *) + | Unix.S_BLK -> + let@ name, out = with_tempfile () in + (* block device must have an initial size *) + ftruncate out 512L ; + let@ blkname, _ = with_temp_blk name in + let@ fd_ro = with_fd @@ open_ro blkname in + let@ fd = with_fd @@ open_wo blkname in + f fd (Some fd_ro) + | Unix.S_CHR -> + let@ fd = with_fd @@ dev_null_out () in + f fd None + +let with_kind_rw kind f = + match kind with + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f fd1 fd2 + | Unix.S_FIFO | Unix.S_DIR | Unix.S_LNK | Unix.S_BLK | Unix.S_REG | Unix.S_CHR + -> + invalid_arg "not a socket" + +let observe_read observed op t dest off len = + let amount = op t dest off len in + assert (amount >= 0) ; + Buffer.add_subbytes observed dest off amount ; + amount + +let observe_write observed op t source off len = + let amount = op t source off len in + assert (amount >= 0) ; + Buffer.add_substring observed source off amount ; + amount + +type 'a or_exn = ('a, Rresult.R.exn_trap) result + +let unwrap_exn = function + | Ok ok -> + ok + | Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + +let concurrently (f, g) (farg, garg) = + (* only one thread at a time reads or writes, atomic not needed *) + let thread_result = ref None in + let thread_fun (tfun, arg) = + thread_result := Some (Rresult.R.trap_exn tfun arg) + in + let t = Thread.create thread_fun (g, garg) in + let res = Rresult.R.trap_exn f farg in + Thread.join t ; + let thread_result = + match !thread_result with + | Some r -> + r + | None -> + Rresult.R.trap_exn failwith "Thread not run?" + in + (res, thread_result) + +type 'a observation = { + elapsed: Mtime.span + ; data: string + ; is_read: [< rdonly | wronly] as 'a +} + +let truncated_string ppf s = + let n = 35 in + if String.length s < 2 * n then + Fmt.string ppf s + else + Fmt.pf ppf "%S...%S" (String.sub s 0 n) + (String.sub s (String.length s - n) n) + +let pp ppf = + Fmt.( + record ~sep:(any ";") + [ + field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ; field "data" (fun t -> t.data) truncated_string + ] + ) + ppf + +type ('a, 'b) observations = {read: 'a; write: 'b; elapsed: Mtime.span} + +module CancellableSleep = struct + type nonrec t = { + wait: (rdonly, sock) make + ; wake: (wronly, sock) make + ; buf: bytes + } + + let with_ f = + let@ wait, wake = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f + { + wait= as_readonly_socket wait + ; wake= as_writeonly_socket wake + ; buf= Bytes.make 1 ' ' + } + + let set_rcvtimeo sock timeo = setsockopt_float sock Unix.SO_RCVTIMEO timeo + + let sleep t dt = + set_rcvtimeo t.wait (Mtime.Span.to_float_ns dt *. 1e-9) ; + try + let (_ : int) = read t.wait t.buf 0 1 in + () + with Unix.Unix_error (Unix.EAGAIN, _, _) -> () + + let cancel t = shutdown_send t.wake +end + +module Delay = struct + type t = {duration: Mtime.span; every_bytes: int} + + let pp = + Fmt.( + record ~sep:(any ";") + [ + field "duration" (fun t -> t.duration) Mtime.Span.pp + ; field "every_bytes" (fun t -> t.every_bytes) int + ] + ) + + let v ~duration ~every_bytes = {duration; every_bytes} + + let apply repeat cancel t op = + let remaining = ref t.every_bytes in + let sleep () = + CancellableSleep.sleep cancel t.duration ; + remaining := t.every_bytes + in + let delayed_op fd buf off len = + (* ensure we'll be able to insert our sleep, limit [len] if needed *) + let n = op fd buf off (Int.min !remaining len) in + remaining := !remaining - n ; + if !remaining <= 0 then sleep () ; + n + in + repeat delayed_op + + let apply_read cancel t op = apply repeat_read cancel t op + + let apply_write cancel t op = apply repeat_write cancel t op +end + +let do_op buf is_read repeat observe op arg off length fd = + fd + |> Option.map @@ fun rd -> + let dt = Mtime_clock.counter () in + let (_ : int) = repeat (observe buf op) rd arg off length in + let elapsed = Mtime_clock.count dt in + let data = Buffer.contents buf in + {is_read; data; elapsed} + +let do_read read rd_buf ~size = + let length = size in + do_op rd_buf `rdonly repeat_read observe_read read (Bytes.make length 'x') 0 + length + +let do_write write buf expected off = + do_op buf `wronly repeat_write observe_write write expected off + (String.length expected - off) + +let wrap_measure f arg = + let dt = Mtime_clock.counter () in + let r = Rresult.R.trap_exn f arg in + let result = (Mtime_clock.count dt, r) in + close arg ; result + +let observe_ro write ~f kind expected = + with_kind_ro kind @@ fun ro wo_opt -> + let written = Buffer.create 0 in + let prepare fd_opt = + let () = + fd_opt + |> Option.iter @@ fun fd -> + as_spipe_opt fd |> Option.iter set_nonblock ; + let (_ : int) = + repeat_write + (observe_write written write) + fd expected 0 (String.length expected) + in + clear_nonblock fd + in + Buffer.length written + in + (* write as much as possible initially, TODO: should be configurable? *) + let off = prepare wo_opt in + let g fd_opt = + fd_opt + |> Option.fold ~none:None ~some:(fun fd -> + let r = do_write write written expected off (as_writable_opt fd) in + close fd ; r + ) + in + let res, thread_result = concurrently (wrap_measure f, g) (ro, wo_opt) in + let elapsed, res = unwrap_exn res in + let write = unwrap_exn thread_result in + let write = + write + |> Option.map @@ fun write -> {write with data= Buffer.contents written} + in + ({read= (); write; elapsed}, res) + +let observe_wo read ~f ~size kind = + with_kind_wo kind @@ fun wo ro_opt -> + let rd_buf = Buffer.create 0 in + (* TODO:set block device size *) + let g fd_opt = + fd_opt + |> Option.fold ~none:None ~some:(fun fd -> + do_read ~size read rd_buf (as_readable_opt fd) + ) + in + let res, thread_result = concurrently (wrap_measure f, g) (wo, ro_opt) in + let elapsed, res = unwrap_exn res in + let read = unwrap_exn thread_result in + let (_ : _ option) = g ro_opt in + let read = + read |> Option.map @@ fun read -> {read with data= Buffer.contents rd_buf} + in + ({write= (); read; elapsed}, res) + +let observe_rw read write ~f ~size kind expected = + with_kind_rw kind @@ fun rw1 rw2 -> + let written = Buffer.create 0 in + let rd_buf = Buffer.create 0 in + let gw fd = do_write write written expected 0 (as_writable_opt fd) + and gr fd = do_read ~size read rd_buf (as_readable_opt fd) in + let g fd = + let r = concurrently (gr, gw) (fd, fd) in + close fd ; r + in + let res, thread_result = concurrently (wrap_measure f, g) (rw1, rw2) in + let elapsed, res = unwrap_exn res in + let read, write = unwrap_exn thread_result in + let read = + read + |> unwrap_exn + |> Option.map @@ fun read -> {read with data= Buffer.contents rd_buf} + and write = + write + |> unwrap_exn + |> Option.map @@ fun write -> {write with data= Buffer.contents written} + in + ({read; write; elapsed}, res) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli new file mode 100644 index 00000000000..2e4ecb6b7d0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli @@ -0,0 +1,202 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps +open Properties +open Operations + +(** {1 Generate test resources} *) + +val with_kind_ro : + Unix.file_kind + -> (([> rdonly], kind) make -> ([> writable], kind) make option -> 'a) + -> 'a +(** [with_kind_ro kind f] creates file descriptors of [kind] type, and calls [f] with it. + For sockets and pipes [f] receives both sides. + For regular files and block devices it receives a writable file. + For character devices it receives a {!val:null} device. +*) + +val with_kind_wo : + Unix.file_kind + -> (([> wronly], kind) make -> ([> readable], kind) make option -> 'a) + -> 'a +(** [with_kind_wo kind f] is like {!val:with_kind_ro} but creates a write only file. +*) + +val with_kind_rw : + Unix.file_kind -> (([> rdwr], kind) make -> ([> rdwr], kind) make -> 'a) -> 'a +(** [with_kind_rw kind f] is like {!val:with_kind_ro} but creates a read-write file. +*) + +(** {1 Observe operations} *) + +val observe_read : + Buffer.t + -> ((([< readable], _) Properties.t as 'a), bytes) operation + -> ('a, bytes) operation +(** [observe_read buf op] wraps the operation [op], and stores all substrings read into [buf]. *) + +val observe_write : + Buffer.t + -> ((([< writable], _) Properties.t as 'a), string) operation + -> ('a, string) operation +(** [observe_write buf op] wraps the operation [op], and stores all substrings written into [buf]. *) + +(** {1 Concurrency helpers} *) + +(** a successful result ['a], or an exception with its backtrace on error. + +@see {!val:unwrap_exn} to reraise the exception with its original backtrace + *) +type 'a or_exn = ('a, Rresult.R.exn_trap) result + +val unwrap_exn : 'a or_exn -> 'a +(** [unwrap_exn t] returns the underlying successful result, or reraises the exception *) + +val concurrently : ('a -> 'b) * ('c -> 'd) -> 'a * 'c -> 'b or_exn * 'd or_exn +(** [concurrently (f, g) (farg, garg)] calls [f farg] and [g garg] in separate threads, + and returns their results. +*) + +(** Sleep that can be interrupted from another thread. + + This uses file descriptors internally, so shouldn't be used as is in XAPI, + because it'd use up 2 file descriptors every time a [with_] is called. + + `pthread_cond_timedwait` could've been used instead, but that is not available in OCaml, + and `pthread_cond*` is known to have deadlock bugs on glibc >= 2.27 + https://sourceware.org/bugzilla/show_bug.cgi?id=25847 +*) +module CancellableSleep : sig + (** cancel signal *) + type t + + val with_ : (t -> 'a) -> 'a + (** [with f] creates a cancellable sleep value and calls [f] with it. *) + + val sleep : t -> Mtime.span -> unit + (** [sleep t duration] sleeps until [duration] has elapsed or [t] has been signaled. *) + + val cancel : t -> unit + (** [cancel t] signals [t] to cancel any sleeps *) +end + +(** 1 Introduce delays + +These are needed to trigger short reads on sockets. +*) + +module Delay : sig + (** a delay specification *) + type t + + val v : duration:Mtime.span -> every_bytes:int -> t + (** [v ~duration ~every_bytes] inserts a sleep for [duration] every [every_bytes] interval. + The sleep can be canceled with [cancel]. + + Note that the time taken to send or receive [after_bytes] is not taken into account to guarantee the insertion of the delay. + *) + + val apply_read : + CancellableSleep.t + -> t + -> ((([< readable], _) Properties.t as 'a), bytes) operation + -> ('a, bytes) operation + (** [apply_read cancel delay op] returns a new operation which calls [op] and every [delay.after_bytes] + calls sleep for [duration] *) + + val apply_write : + CancellableSleep.t + -> t + -> ((([< writable], _) Properties.t as 'a), string) operation + -> ('a, string) operation + (** [apply_write cancel delay op] returns a new operation which calls [op] and every [delay.after_bytes] + calls sleep for [duration] *) + + val pp : t Fmt.t + (** [pp formatter t] is a pretty printer for [t] on [formatter]. *) +end + +(** {1 Observe file descriptor actions} + + File descriptors are created in pairs, and we can observe the actions from the other end of a pipe or socketpair. + For regular files we can prepare some data before, or inspect the data at the end. + *) + +(** an observation from the point of view of the observer *) +type 'a observation = { + elapsed: Mtime.span + (** the elapsed time for the observer until EOF was encountered *) + ; data: string (** the data that was sent or received *) + ; is_read: [< rdonly | wronly] as 'a + (** observer's point of view, so observing actions on a readonly pipe will be a write action *) +} + +val pp : _ observation Fmt.t +(**[pp formatter obs] pretty prints [obs]ervation on [formatter]. *) + +(** read and write observations, and the time elapsed for the function under test *) +type ('a, 'b) observations = {read: 'a; write: 'b; elapsed: Mtime.span} + +val observe_ro : + (([> writable], kind) Properties.t, string) operation + -> f:(([< readable > `rdonly], kind) make -> 'a) + -> Unix.file_kind + -> string + -> (unit, [> wronly] observation option) observations * 'a or_exn +(** [observe_ro write ~f kind expected] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + + @param write the operation used for writing, allows insertion of delays + @param expected the string to write to the file descriptor + @returns an observation of [f]'s actions on the file descriptor and [f]'s result + *) + +val observe_wo : + (([> readable], kind) Properties.t, bytes) operation + -> f:(([< writable > `wronly], kind) make -> 'a) + -> size:int + -> Unix.file_kind + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [observe_wo read ~f ~size kind] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + It expects [size] bytes written by [f]. + + @returns an observation of [f]'s actions on the file descriptor and [f]'s result + *) + +val observe_rw : + (([> readable], kind) Properties.t, bytes) operation + -> (([> writable], kind) Properties.t, string) operation + -> f:((rdwr, kind) make -> 'a) + -> size:int + -> Unix.file_kind + -> string + -> ([> rdonly] observation option, [> wronly] observation option) observations + * 'a or_exn +(** [observe_rw read write ~f ~size kind expected] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + + @param read the operation used for reading, allows insertion of delays + @param write the operation used for writing, allows insertion of delays + @param expected the string to write to the file descriptor + @returns an observation of [f]'s actions on the file descriptor and [f]'s result + *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune new file mode 100644 index 00000000000..29ea531dcad --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune @@ -0,0 +1,6 @@ +; This is a test framework, but we still need to test it +(test + (package xapi-stdext-unix) + (name test_xapi_fd_test) + (libraries xapi_fd_test alcotest fmt mtime.clock.os) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml new file mode 100644 index 00000000000..b6ae12eb035 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml @@ -0,0 +1,115 @@ +open Xapi_fdcaps +open Operations +open Xapi_fd_test.Observations +open Syntax + +let skip_blk = function + | Unix.S_BLK -> + if Unix.geteuid () <> 0 then + Alcotest.skip () + | _ -> + () + +let expected = "string to be written" + +(* +let prepare fd_opt = + let buf = Buffer.create 0 in + let () = + fd_opt + |> Option.iter @@ fun fd -> + let (_ : int) = + observe_write buf single_write_substring fd expected 0 + (String.length expected) + in + () + in + buf +*) + +let test_kind_ro kind () = + skip_blk kind ; + let f fd = + let b = Bytes.make 128 'x' in + let n = read fd b 0 (Bytes.length b) in + close fd ; Bytes.sub_string b 0 n + in + let observed, res = observe_ro single_write_substring kind expected ~f in + let actual = unwrap_exn res in + match observed.write with + | Some observed_write -> + Alcotest.(check' string) + ~msg:"expected string received" ~expected:observed_write.data ~actual + | None -> + () + +let test_kind_wo kind () = + skip_blk kind ; + let f fd = + let n = single_write_substring fd expected 0 (String.length expected) in + close fd ; String.sub expected 0 n + in + let observed, res = observe_wo read kind ~f ~size:128 in + let actual = unwrap_exn res in + match observed.read with + | Some observed_read -> + Alcotest.(check' string) + ~msg:"expected string received" ~expected:observed_read.data ~actual + | None -> + () + +let kinds = Unix.[S_BLK; S_CHR; S_FIFO; S_REG; S_SOCK] + +let test_kind_all test = + kinds + |> List.map @@ fun kind -> + Alcotest.test_case (Fmt.to_to_string Safefd.pp_kind kind) `Quick (test kind) + +let test_cancellable_sleep () = + let@ t = CancellableSleep.with_ in + let sleep_duration = Mtime.Span.(2 * s) in + let sleeper () = + let dt = Mtime_clock.counter () in + let () = CancellableSleep.sleep t sleep_duration in + Mtime_clock.count dt + in + let waker_duration = 0.1 in + let waker () = Unix.sleepf waker_duration ; CancellableSleep.cancel t in + let slept, _ = concurrently (sleeper, waker) ((), ()) in + let slept = unwrap_exn slept in + if Mtime.Span.compare slept sleep_duration >= 0 then + Alcotest.failf + "Sleep wasn't interrupted as expected, total duration = %a; waked at = \ + %fs" + Mtime.Span.pp slept waker_duration ; + if Mtime.Span.to_float_ns slept *. 1e-9 < waker_duration then + Alcotest.failf "Sleep was shorter than expected, total duration = %a < %fs" + Mtime.Span.pp slept waker_duration + +let test_full_sleep () = + let@ t = CancellableSleep.with_ in + let sleep_duration = Mtime.Span.(10 * ms) in + let slept = + let dt = Mtime_clock.counter () in + let () = CancellableSleep.sleep t sleep_duration in + Mtime_clock.count dt + in + if Mtime.Span.compare slept sleep_duration < 0 then + Alcotest.failf "Sleep was shorter than expected, total duration = %a < %a" + Mtime.Span.pp slept Mtime.Span.pp sleep_duration + +let () = + setup () ; + (* kill test after 5s, it must've gotten stuck.. *) + (* let (_: int) = Unix.alarm 5 in *) + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("test_kind_ro", test_kind_all test_kind_ro) + ; ("test_kind_wo", test_kind_all test_kind_wo) + ; ( "cancellable sleep" + , [ + Alcotest.test_case "cancellable" `Quick test_cancellable_sleep + ; Alcotest.test_case "full" `Quick test_full_sleep + ] + ) + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune new file mode 100644 index 00000000000..cd3754e6a21 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune @@ -0,0 +1,11 @@ +; Keep dependencies minimal here, ideally just OCaml stdlib +; This will be used to test other functions in stdext, so it should not itself rely on other stdext libs! +(library + (public_name xapi-stdext-unix.fdcaps) + (name xapi_fdcaps) + (libraries fmt unix threads.posix) + (flags (:standard -principal)) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml new file mode 100644 index 00000000000..bce25cdcd03 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml @@ -0,0 +1,315 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Properties + +type +!'a props = { + props: ('b, 'c) Properties.props + ; custom_ftruncate: (int64 -> unit) option + ; fd: Safefd.t +} + constraint 'a = ('b, 'c) Properties.props + +type +!'a t = 'a props constraint 'a = (_, _) Properties.t + +type (+!'a, +!'b) make = ('a, 'b) Properties.t t + +let dump ppf = + Fmt.( + Dump.( + record + [ + field "props" (fun t -> t.props) pp + ; field "custom_ftruncate" + (fun t -> Option.is_some t.custom_ftruncate) + bool + ; field "fd" (fun t -> t.fd) Safefd.dump + ] + ) + ) + ppf + +let pp ppf = + Fmt.( + record + ~sep:Fmt.(any "; ") + [ + field "props" (fun t -> t.props) pp + ; field "custom_ftruncate" + (fun t -> Option.is_some t.custom_ftruncate) + bool + ; field "fd" (fun t -> t.fd) Safefd.pp + ] + ) + ppf + +let close t = Safefd.idempotent_close_exn t.fd + +let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) + +let as_readable_opt t = + match as_readable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_writable_opt t = + match as_writable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_spipe_opt t = + match + (Properties.as_kind_opt `sock t.props, Properties.as_kind_opt `fifo t.props) + with + | Some props, _ | _, Some props -> + Some {t with props} + | None, None -> + None + +let with_fd t f = + let finally () = close t in + Fun.protect ~finally (fun () -> f t) + +module Syntax = struct let ( let@ ) f x = f x end + +open Syntax + +let with_fd2 (fd1, fd2) f = + let@ fd1 = with_fd fd1 in + let@ fd2 = with_fd fd2 in + f (fd1, fd2) + +let make ?custom_ftruncate props fd : 'a t = + {fd= Safefd.of_file_descr fd; props; custom_ftruncate} + +let make_ro_exn kind fd = make (Properties.make `rdonly kind) fd + +let make_wo_exn kind fd = make (Properties.make `wronly kind) fd + +let make_rw_exn ?custom_ftruncate kind fd = + make (Properties.make `rdwr kind) ?custom_ftruncate fd + +let pipe () = + let kind = `fifo in + let ro, wo = Unix.pipe ~cloexec:true () in + (make_ro_exn kind ro, make_wo_exn kind wo) + +let socketpair domain typ proto = + let kind = `sock in + let fd1, fd2 = Unix.socketpair ~cloexec:true domain typ proto in + (make_rw_exn kind fd1, make_rw_exn kind fd2) + +let openfile_ro kind path flags = + make_ro_exn kind + @@ Unix.openfile path (Unix.O_RDONLY :: Unix.O_CLOEXEC :: flags) 0 + +let openfile_rw ?custom_ftruncate kind path flags = + make_rw_exn ?custom_ftruncate kind + @@ Unix.openfile path (Unix.O_RDWR :: Unix.O_CLOEXEC :: flags) 0 + +let openfile_wo kind path flags = + make_wo_exn kind + @@ Unix.openfile path (Unix.O_WRONLY :: Unix.O_CLOEXEC :: flags) 0 + +let creat path flags perm = + make_rw_exn `reg + @@ Unix.openfile path + (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags) + perm + +let kind_of_fd fd = of_unix_kind Unix.LargeFile.((fstat fd).st_kind) + +let stdin = make_ro_exn (kind_of_fd Unix.stdin) Unix.stdin + +let stdout = make_wo_exn (kind_of_fd Unix.stdout) Unix.stdout + +let stderr = make_wo_exn (kind_of_fd Unix.stderr) Unix.stderr + +let dev_null_out () = openfile_wo `chr "/dev/null" [] + +let dev_null_in () = openfile_ro `chr "/dev/null" [] + +let dev_zero () = openfile_ro `chr "/dev/zero" [] + +let shutdown_recv t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_RECEIVE + +let shutdown_send t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND + +let as_readonly_socket t = + shutdown_send t ; + {t with props= Properties.make `rdonly `sock} + +let as_writeonly_socket t = + shutdown_recv t ; + {t with props= Properties.make `wronly `sock} + +let shutdown_all t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL + +let setsockopt_float t opt value = + Unix.setsockopt_float (Safefd.unsafe_to_file_descr_exn t.fd) opt value + +let ftruncate t size = + match t.custom_ftruncate with + | None -> + Unix.LargeFile.ftruncate (Safefd.unsafe_to_file_descr_exn t.fd) size + | Some f -> + f size + +let lseek t off whence = + Unix.LargeFile.lseek (Safefd.unsafe_to_file_descr_exn t.fd) off whence + +let read t buf off len = + Unix.read (Safefd.unsafe_to_file_descr_exn t.fd) buf off len + +let single_write_substring t buf off len = + Unix.single_write_substring (Safefd.unsafe_to_file_descr_exn t.fd) buf off len + +let fstat t = Unix.LargeFile.fstat (Safefd.unsafe_to_file_descr_exn t.fd) + +let dup t = + { + t with + fd= + t.fd + |> Safefd.unsafe_to_file_descr_exn + |> Unix.dup + |> Safefd.of_file_descr + } + +let set_nonblock t = Unix.set_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) + +let clear_nonblock t = Unix.clear_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) + +let with_tempfile ?size () f = + let name, ch = + Filename.open_temp_file ~mode:[Open_binary] "xapi_fdcaps" "tmp" + in + let finally () = + close_out_noerr ch ; + try Unix.unlink name with Unix.Unix_error (_, _, _) -> () + in + let@ () = Fun.protect ~finally in + let t = ch |> Unix.descr_of_out_channel |> make_wo_exn `reg in + let@ t = with_fd t in + size |> Option.iter (fun size -> ftruncate t size) ; + f (name, t) + +let check_output cmd args = + let cmd = Filename.quote_command cmd args in + let ch = Unix.open_process_in cmd in + let finally () = + try + let (_ : Unix.process_status) = Unix.close_process_in ch in + () + with _ -> () + in + Fun.protect ~finally @@ fun () -> + let out = In_channel.input_all ch |> String.trim in + match Unix.close_process_in ch with + | Unix.WEXITED 0 -> + out + | _ -> + failwith (Printf.sprintf "%s exited nonzero" cmd) + +let with_temp_blk ?(sector_size = 512) name f = + let blkdev = + check_output "losetup" + [ + "--show" + ; "--sector-size" + ; string_of_int sector_size + ; "--direct-io=on" + ; "--find" + ; name + ] + in + let custom_ftruncate size = + Unix.LargeFile.truncate name size ; + let (_ : string) = check_output "losetup" ["--set-capacity"; name] in + () + in + let finally () = + let (_ : string) = check_output "losetup" ["--detach"; blkdev] in + () + in + let@ () = Fun.protect ~finally in + let@ t = with_fd @@ openfile_rw ~custom_ftruncate `blk blkdev [] in + f (blkdev, t) + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore + +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +let repeat_read op fd buf off len = + let rec loop consumed = + let off = off + consumed and len = len - consumed in + if len = 0 then + consumed (* we filled the buffer *) + else + match op fd buf off len with + | 0 (* EOF *) + | (exception + Unix.( + Unix_error + ((ECONNRESET | ENOTCONN | EAGAIN | EWOULDBLOCK | EINTR), _, _)) + ) (* connection error or non-blocking socket *) -> + consumed + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (consumed + n) + in + loop 0 + +let repeat_write op fd buf off len = + let rec loop written = + let off = off + written and len = len - written in + if len = 0 then + written (* we've written the entire buffer *) + else + match op fd buf off len with + | 0 + (* should never happen, but we cannot retry now or we'd enter an infinite loop *) + | (exception + Unix.( + Unix_error + ( ( ECONNRESET + | EPIPE + | EINTR + | ENETDOWN + | ENETUNREACH + | EAGAIN + | EWOULDBLOCK ) + , _ + , _ + )) + ) (* connection error or nonblocking socket *) -> + written + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (written + n) + in + loop 0 + +module For_test = struct + let unsafe_fd_exn t = Safefd.unsafe_to_file_descr_exn t.fd +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli new file mode 100644 index 00000000000..6097f8cddf5 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli @@ -0,0 +1,296 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Statically enforce file descriptor capabilities using type parameters. + + *) + +open Properties + +(** {1 Type and pretty printers } *) + +(** a file descriptor with properties + Upper bounds are avoided here so that this type can be used in functors + *) +type +!'a props constraint 'a = (_, _) Properties.props + +(** like {!type:props} but with upper bounds on properties *) +type +!'a t = 'a props constraint 'a = (_, _) Properties.t + +(** convenience type for declaring properties *) +type (+!'a, +!'b) make = ('a, 'b) Properties.t t + +val pp : _ t Fmt.t +(** [pp formatter t] pretty prints [t] on [formatter]. *) + +val dump : _ t Fmt.t +(** [dump formatter t] prints a debug representation of [t] on [formatter]. *) + +(** {1 Initialization} *) + +val setup : unit -> unit +(** [setup ()] installs a SIGPIPE handler. + + By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. + *) + +(** {1 Runtime property tests} *) + +val as_readable_opt : + (([< rw] as 'a), 'b) make -> ([> readable], 'b) make option +(** [as_readable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_writable_opt : + (([< rw] as 'a), 'b) make -> ([> writable], 'b) make option +(** [as_writable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_spipe_opt : ('a, [< kind]) make -> ('a, [> espipe]) make option +(** [as_spipe_opt t] returns [Some t] when [t] is a socket or pipe, and [None] otherwise. *) + +(** {1 With resource wrappers} *) + +val with_fd : 'a t -> ('a t -> 'b) -> 'b +(** [with_fd t f] calls [f t] and always closes [t] after [f] finishes. + [f] can also close [t] earlier if it wants to without a double close error. +*) + +val with_fd2 : 'a t * 'b t -> ('a t * 'b t -> 'c) -> 'c +(** [with_fd2 fd1 fd2 f] calls [f fd1 fd2] and always closes [t] after [f] finishes. *) + +module Syntax : sig + val ( let@ ) : ('a -> 'b) -> 'a -> 'b + (** [let@ fd = with_fd t in ... use fd] *) +end + +(** {1 {!mod:Unix} wrappers} *) + +val stdin : ([> rdonly], kind) make +(** [stdin] is a readonly file descriptor of unknown kind *) + +val stdout : ([> wronly], kind) make +(** [stdout] is a writeonly file descriptor of unknown kind *) + +val stderr : ([> wronly], kind) make +(** [stderr] is a writeonly file descriptor of unknown kind *) + +val close : _ t -> unit +(** [close t] closes t. Doesn't raise an exception if it is already closed. + Other errors from the underlying {!val:Unix.close} are propagated. + *) + +val fsync : _ t -> unit +(** [fsync t] flushes [t] buffer to disk. + + Note that the file doesn't necessarily have to be writable, e.g. you can fsync a readonly open directory. + *) + +val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make +(** [pipe ()] creates an unnamed pipe. + @see {!val:Unix.pipe} + *) + +val socketpair : + Unix.socket_domain + -> Unix.socket_type + -> int + -> ([> rdwr], [> sock]) make * ([> rdwr], [> sock]) make +(** [socketpair domain type protocol] creates a socket pair. + @see {!val:Unix.socketpair} + *) + +val openfile_ro : 'a -> string -> Unix.open_flag list -> ([> rdonly], 'a) make +(** [openfile_ro kind path flags] opens an existing [path] readonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_rw : + ?custom_ftruncate:(int64 -> unit) + -> 'a + -> string + -> Unix.open_flag list + -> ([> rdwr], 'a) make +(** [openfile_rw kind path flags] opens an existing [path] readwrite. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_wo : 'a -> string -> Unix.open_flag list -> ([> wronly], 'a) make +(** [openfile_wo kind path flags] opens an existing [path] writeonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val creat : string -> Unix.open_flag list -> int -> ([> rdwr], [> reg]) make +(** [creat path flags perms] creates [path] readwrite. The path must not already exist. + + @param perms initial permissions for [path] + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val dev_null_out : unit -> ([> wronly], [> chr]) make +(** [dev_null_out ()] is "/dev/null" opened for writing *) + +val dev_null_in : unit -> ([> rdonly], [> chr]) make +(** [dev_null_in ()] is "/dev/null" opened for reading *) + +val dev_zero : unit -> ([> rdonly], [> chr]) make +(** [dev_zero ()] is "/dev/zero" opened for reading *) + +val shutdown_recv : ([< readable], [< sock]) make -> unit +(** [shutdown_recv t] shuts down receiving on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_send : ([< writable], [< sock]) make -> unit +(** [shutdown_send t] shuts down sending on [t]. + + @see {!Unix.shutdown} + *) + +val as_readonly_socket : + ([< readable], [< sock]) make -> ([> rdonly], [> sock]) make +(** [as_readonly_socket t] calls {!val:shutdown_send} and returns a readonly socket, + if it was originally readable. *) + +val as_writeonly_socket : + ([< writable], [< sock]) make -> ([> wronly], [> sock]) make +(** [as_writeonly_socket t] calls {!val:shutdown_recv} and returns a writeonly socket, + if it was originally readable. *) + +val shutdown_all : ([< rdwr], [< sock]) make -> unit +(** [shutdown_all t] shuts down both receiving and sending on [t]. + + @see {!Unix.shutdown} + *) + +val ftruncate : ([< writable], [< truncatable]) make -> int64 -> unit +(** [ftruncate t size] sets the size of the regular file [t] to [size]. + + @see {!Unix.ftruncate} + *) + +val lseek : (_, [< seekable]) make -> int64 -> Unix.seek_command -> int64 +(** [lseek t off whence] sets the position of [t] to [off] with origin specified by [whence]. + + @see {!Unix.lseek} +*) + +val read : ([< readable], _) make -> bytes -> int -> int -> int +(** [read t buf off len] + @see {!Unix.read} + *) + +val single_write_substring : + ([< writable], _) make -> string -> int -> int -> int +(** [single_write_substring t buf off len] + + @see {!Unix.single_write_substring} +*) + +val fstat : _ t -> Unix.LargeFile.stats +(** [fstat t] is {!val:Unix.LargeFile.fstat} *) + +val dup : 'a t -> 'a t +(** [dup t] is {!val:Unix.dup} on [t]. *) + +val set_nonblock : (_, [< espipe]) make -> unit +(** [set_nonblock t]. + + Only pipes, FIFOs and sockets are guaranteed to not block when this flag is set. + Although it is possible to set regular files and block devices as non-blocking, they currently still block + (although according to the manpage this may change in the future) + + @see {!Unix.set_nonblock} + *) + +val clear_nonblock : _ t -> unit +(** [clear_nonblock t]. + + We do not restrict clearing the non-blocking flag: that is just reverting back to default behaviour. + + @see {!Unix.clear_nonblock} + *) + +val setsockopt_float : + (_, [< sock]) make -> Unix.socket_float_option -> float -> unit +(** [set_sockopt_float t opt val] sets the socket option [opt] to [val] for [t]. *) + +(** {1 Temporary files} *) + +val with_tempfile : + ?size:int64 -> unit -> (string * ([> wronly], [> reg]) make -> 'a) -> 'a +(** [with_tempfile () f] calls [f (name, outfd)] with the name of a temporary file and a file descriptor opened for writing. + Deletes the temporary file when [f] finishes. *) + +val with_temp_blk : + ?sector_size:int -> string -> (string * ([> rdwr], [> blk]) make -> 'a) -> 'a +(** [with_temp_blk ?sector_size path f] calls [f (name, fd)] with a name and file descriptor pointing to a block device. + The block device is temporarily created on top of [path]. + + Deletes the block device when [f] finishes. + Only works when run as root. + + @param sector_size between 512 and 4096 +*) + +(** {1 Operation wrappers} + + The low-level {!val:read} and {!val:single_write_substring} can raise different exceptions + to mean end-of-file/disconnected depending on the file's kind. + + If you want to consider disconnectins as end-of-file then use these wrappers. + *) + +(** a buffered operation on a file descriptors. + + @see {!val:read} and {!val:single_write_substring} + *) +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +val repeat_read : ('a, bytes) operation -> ('a, bytes) operation +(** [repeat_read op buf off len] repeats [op] on the supplied buffer until EOF or a connection error is encountered. + The following connection errors are treated as EOF and are not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.ENOTCONN}. + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if EOF was encountered. +*) + +val repeat_write : ('a, string) operation -> ('a, string) operation +(** [repeat_write op buf off len] repeats [op] on the supplied buffer until a connection error is encountered or the entire buffer is written. + The following are treated as connection errors and not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.EPIPE}, {!val:Unix.ENETDOWN}, {!val:Unix.ENETUNREACH} + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if we were not able to complete the write due to a connection error. +*) + +(**/**) + +module For_test : sig + val unsafe_fd_exn : _ t -> Unix.file_descr +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml new file mode 100644 index 00000000000..d26194cfeb9 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml @@ -0,0 +1,140 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type (+!'a, +!'b) props = {rw: 'a; kind: 'b} + +type rdonly = [`rdonly] + +type wronly = [`wronly] + +type rdwr = [`rdwr] + +let pp_rw fmt = + Fmt.of_to_string + (function #rdonly -> "RDONLY" | #wronly -> "WRONLY" | #rdwr -> "RDWR") + fmt + +type reg = [`reg] + +type blk = [`blk] + +type chr = [`chr] + +type dir = [`dir] + +type lnk = [`lnk] + +type fifo = [`fifo] + +type sock = [`sock] + +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +let to_unix_kind = + let open Unix in + function + | #reg -> + S_REG + | #blk -> + S_BLK + | #chr -> + S_CHR + | #dir -> + S_DIR + | #lnk -> + S_LNK + | #fifo -> + S_FIFO + | #sock -> + S_SOCK + +let of_unix_kind = + let open Unix in + function + | S_REG -> + `reg + | S_BLK -> + `blk + | S_CHR -> + `chr + | S_DIR -> + `dir + | S_LNK -> + `lnk + | S_FIFO -> + `fifo + | S_SOCK -> + `sock + +let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt + +let pp fmt = + Fmt.( + record + ~sep:Fmt.(any ", ") + [field "rw" (fun t -> t.rw) pp_rw; field "kind" (fun t -> t.kind) pp_kind] + ) + fmt + +type readable = [rdonly | rdwr] + +type writable = [wronly | rdwr] + +type rw = [rdonly | wronly | rdwr] + +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +let as_readable ({rw= #readable; _} as t) = t + +let as_writable ({rw= #writable; _} as t) = t + +let as_readable_opt = function + | {rw= #readable; _} as x -> + Some x + | {rw= #wronly; _} -> + None + +let as_writable_opt = function + | {rw= #writable; _} as x -> + Some x + | {rw= #rdonly; _} -> + None + +type espipe = [fifo | sock] + +let as_kind_opt expected ({kind; _} as t) = + (* we cannot compare the values directly because we want to keep the type parameters distinct *) + match (kind, expected) with + | #reg, #reg -> + Some {t with kind= expected} + | #blk, #blk -> + Some {t with kind= expected} + | #chr, #chr -> + Some {t with kind= expected} + | #dir, #dir -> + Some {t with kind= expected} + | #lnk, #lnk -> + Some {t with kind= expected} + | #fifo, #fifo -> + Some {t with kind= expected} + | #sock, #sock -> + Some {t with kind= expected} + | #kind, #kind -> + None + +type seekable = [reg | blk] + +type truncatable = reg + +let make rw kind = {rw; kind} diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli new file mode 100644 index 00000000000..6b51a3ab7a7 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli @@ -0,0 +1,195 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Static file property checking + + When file descriptors are open they have: + * a file kind: ({!type:reg}, {!type:blk), {!type:chr}, {!type:lnk}, {!type:fifo}, {!type:sock}) + * an open mode: {!type:readonly}, {!type:writeonly}, {!type:readwrite} depending on the {!type:Unix.open_flag} used + + Depending on these properties there are {!val:Unix} operations on file descriptors that always fail, e.g.: + * writing to a read-only file + * socket operation on non-socket + * seeking on a pipe + * ... + + The read-write property can also change at runtime: + * {!val:Unix.shutdown} can be used to shutdown the socket in either direction + + We track the property of the file at open time, and we reject operations that we can statically determine to always fail. + This doesn't guarantee the absence of runtime errors, but catches programming errors like accidentally swapping the read and write ends of a pipe, + or attempting to set a socket timeout on a pipe. + + We use polymorphic variants as type parameters to track these properties: they are simple to use and work well with type inference. + They also allow dispatching at runtime on the actual capabilities available, although they could be purely compile-time types (phantom types). + + Alternative approaches (typically with phantom types): + * abstract types as phantom type parameters: don't work well with type inference, and cannot express removing a property + * behavioural types (recursive polymorphic variants) can express removing a property, but error messages and type signatures become too long + * object phantom types strike a good balance between clarity of error messages and complexity of type signatures + + It'd be also possible to use purely boolean properties (capabilities), but that causes a long type signature, and allows expressing meaningless combinations, + such as a file that is both a socket and seekable, which is impossible. + Instead we directly map the concepts from the Unix module to a polymorphic variant (e.g. instead of separate read and write properties we have the 3 properties from the Unix module). + +{b References.} +{ul + {- Yaron Minsky. + {e {{:https://blog.janestreet.com/howto-static-access-control-using-phantom-types/}HOWTO: Static access control using phantom types}. 2008.}} + {- KC Sivaramakrishnan. + {e {{:https://kcsrk.info/ocaml/types/2016/06/30/behavioural-types/#file-descriptors}Behavioural types}. 2016.}} + {- Florian Angeletti. + {e {{:https://stackoverflow.com/a/55081337}Object phantom types}. 2019.}} +} +*) + +(** {1 File properties} + + Polymorphic type parameters for the set of properties a file descriptor may have on a given codepath. + E.g. {[> rdonly | wronly]} means that this codepath may be reached by a file descriptor with either of these properties, + although of course a file descriptor can only have one of these properties at a time. + + Usual rules for using polymorphic variants apply: + * when receiving a type declare an upper bound on what the code can handle, e.g. : {[< readable]} + * when returning a type declare a lower bound to make type inference/unification work, e.g. : {[> readable]} + + Naming conventions: + * [type property ] + * [val as_property : [< property] t -> [> property] t] + * [val as_property_opt: [< all] t -> [> property] t option] +*) + +(** file properties: {!type:rw}, {!type:kind} + + Upper bounds are avoided here to make the type usable in functors + *) +type (+!'a, +!'b) props + +(** {2 Read/write property} + + A file can be read-only, write-only, or read-write. +*) + +(** file opened with {!val:Unix.O_RDONLY} or the read end of a pipe *) +type rdonly = [`rdonly] + +(** file opened with {!val:Unix.O_WRONLY} or the write end of a pipe *) +type wronly = [`wronly] + +(** file opened with {!val:Unix.O_RDWR} or a socketpair *) +type rdwr = [`rdwr] + +(** file opened with either {!val:Unix.O_RDONLY} or {!val:Unix.O_RDWR} *) +type readable = [rdonly | rdwr] + +(** file opened with either {!val:Unix.O_WRONLY} or {!val:Unix.O_RDWR} *) +type writable = [wronly | rdwr] + +(** the read-write property *) +type rw = [rdonly | wronly | rdwr] + +val pp_rw : Format.formatter -> [< rw] -> unit +(** [pp_rw formatter rw] pretty prints the [rw] state on [formatter]. *) + +(** {2 File kind} *) + +(** A regular file, {!val:Unix.S_REG} *) +type reg = [`reg] + +(** A block device, {!val:Unix.S_BLK} *) +type blk = [`blk] + +(** A character device, {!val:Unix.S_CHR} *) +type chr = [`chr] + +(** A directory, {!val:Unix.S_DIR} *) +type dir = [`dir] + +(** A symbolic link, {!val:Unix.S_LNK} *) +type lnk = [`lnk] + +(** A pipe or FIFO, {!val:Unix.S_FIFO} *) +type fifo = [`fifo] + +(** A socket, {!val:Unix.S_SOCK} *) +type sock = [`sock] + +(** a {!type:Unix.file_kind} *) +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +val pp_kind : Format.formatter -> [< kind] -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +(** {2 Property type} *) + +(** upper bounds on properties *) +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +(** {2 Operations on read-write properties} *) + +val as_readable : ([< readable], 'a) t -> ([> readable], 'a) t +(** [as_readable t] requires [t] to be readable and ignores the writeonly property. *) + +val as_writable : ([< writable], 'a) t -> ([> writable], 'a) t +(** [as_writable t] requires [t] to be writable and ignores the readonly property. *) + +val as_readable_opt : ([< rw], 'a) t -> ([> readable], 'a) t option +(** [as_readable_opt t] tests for the presence of the readable property at runtime. + + @returns [Some t] when [t] is readable, and [None] otherwise +*) + +val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option +(** [as_writable_opt t] tests for the presence of the writable property at runtime. + + @returns [Some t] when [t] is writable, and [None] otherwise +*) + +(** {2 Operations on file kind properties} *) + +val to_unix_kind : kind -> Unix.file_kind +(** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) + +val of_unix_kind : Unix.file_kind -> kind +(** [of_unix_kind kind] converts the {!type:Unix.file_kind} to {!type:kind}. *) + +(** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) +type espipe = [fifo | sock] + +val as_kind_opt : ([< kind] as 'a) -> ('b, [< kind]) t -> ('b, 'a) t option +(** [as_kind_opt kind t] checks whether [t] is of type [kind]. + + @returns [Some t] if [t] is of type [kind], and [None] otherwise + *) + +(** {2 Properties derived from file kind} *) + +(** seek may be implementation defined on devices other than regular files or block devices. + + E.g. {!type:chr} devices would always return 0 when seeking, which doesn't follow the usual semantics of seek. +*) +type seekable = [reg | blk] + +(** truncate only works on regular files *) +type truncatable = reg + +(** {2 Create properties} *) + +val make : ([< rw] as 'a) -> ([< kind] as 'b) -> ('a, 'b) t +(** [make rw kind] builds a file property *) + +(** {2 Pretty printing} *) + +val pp : Format.formatter -> (_, _) t -> unit +(** [pp formatter t] pretty prints the properties on [formatter]. *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml new file mode 100644 index 00000000000..1d0d3a92b6d --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml @@ -0,0 +1,185 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let string_of_file_kind = + let open Unix in + function + | S_REG -> + "regular file" + | S_BLK -> + "block device" + | S_CHR -> + "character device" + | S_DIR -> + "directory" + | S_LNK -> + "symlink" + | S_FIFO -> + "FIFO/pipe" + | S_SOCK -> + "socket" + +let pp_kind = Fmt.of_to_string string_of_file_kind + +module Identity = struct + type t = { + kind: Unix.file_kind + ; device: int + ; inode: int (* should be int64? *) + } + + let of_fd fd = + let open Unix.LargeFile in + let stat = fstat fd in + {kind= stat.st_kind; device= stat.st_dev; inode= stat.st_ino} + + let same a b = a.kind = b.kind && a.device = b.device && a.inode = b.inode + + let pp = + Fmt.( + record + ~sep:Fmt.(any ", ") + [ + field "kind" (fun t -> t.kind) pp_kind + ; field "device" (fun t -> t.device) int + ; field "inode" (fun t -> t.inode) int + ] + ) +end + +type t = { + fd: (Unix.file_descr, Printexc.raw_backtrace) result Atomic.t + ; opened_at: Printexc.raw_backtrace + ; original: Identity.t +} + +let pp ppf t = + (* print only essential info that fits on a single line *) + Fmt.pf ppf "@[FD %a: %a@]" + (Fmt.result ~ok:Fmt.(any "open") ~error:Fmt.(any "closed")) + (Atomic.get t.fd) Identity.pp t.original + +let pp_closed ppf bt = + let exception Closed_at in + Fmt.exn_backtrace ppf (Closed_at, bt) + +let pp_opened_at ppf bt = + let exception Opened_at in + Fmt.exn_backtrace ppf (Opened_at, bt) + +let dump = + Fmt.( + Dump.( + record + [ + field "fd" + (fun t -> Atomic.get t.fd) + Fmt.Dump.(result ~ok:(any "opened") ~error:pp_closed) + ; field "opened_at" (fun t -> t.opened_at) pp_opened_at + ; field "original" (fun t -> t.original) Identity.pp + ] + ) + ) + +let location () = + (* We could raise and immediately catch an exception but that will have a very short stacktrace, + [get_callstack] is better. + *) + Printexc.get_callstack 1000 + +let nop = + { + fd= Atomic.make (Error (location ())) + ; opened_at= Printexc.get_callstack 0 + ; original= Identity.of_fd Unix.stdin + } + +let check_exn ~caller t fd = + let actual = Identity.of_fd fd in + if not (Identity.same t.original actual) then ( + let msg = + Format.asprintf "@[File descriptor mismatch: %a <> %a@]" Identity.pp + t.original Identity.pp actual + in + (* invalidate FD so nothing else uses it anymore, we know it points to elsewhere now *) + Atomic.set t.fd (Error (location ())) ; + (* raise backtrace with original open location *) + Printexc.raise_with_backtrace + Unix.(Unix_error (EBADF, caller, msg)) + t.opened_at + ) + +let close_common_exn t = + let closed = Error (location ()) in + (* ensure noone else can access it, before we close it *) + match Atomic.exchange t.fd closed with + | Error _ as e -> + (* put back the original backtrace *) + Atomic.set t.fd e ; e + | Ok fd -> + check_exn ~caller:"close_common_exn" t fd ; + Ok (Unix.close fd) + +let close_exn t = + match close_common_exn t with + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + (* raise with previous close's backtrace *) + Printexc.raise_with_backtrace ebadf bt + | Ok () -> + () + +let idempotent_close_exn t = + let (_ : _ result) = close_common_exn t in + () + +let leak_count = Atomic.make 0 + +let leaked () = Atomic.get leak_count + +let finalise t = + match Atomic.get t.fd with + | Ok _ -> + Atomic.incr leak_count ; + if Sys.runtime_warnings_enabled () then + Format.eprintf "@.Warning: leaked file descriptor detected:@,%a@]@." + pp_opened_at t.opened_at + | Error _ -> + () + +let of_file_descr fd = + let v = + { + fd= Atomic.make (Ok fd) + ; opened_at= location () + ; original= Identity.of_fd fd + } + in + Gc.finalise finalise v ; v + +let unsafe_to_file_descr_exn t = + match Atomic.get t.fd with + | Ok fd -> + fd + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + Printexc.raise_with_backtrace ebadf bt + +let with_fd_exn t f = + let fd = unsafe_to_file_descr_exn t in + let r = f fd in + check_exn ~caller:"with_fd_exn" t fd ; + r + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli new file mode 100644 index 00000000000..710d1a5ee47 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli @@ -0,0 +1,115 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Safe wrapper around {!type:Unix.file_descr} that detects "use after close" errors + + {!type:Unix.file_descr} is just an integer and cannot track whether {!val:Unix.close} has been called. + File descriptor numbers are reused by newly open file descriptors, so using a file descriptor that is already closed + doesn't always result in a visible error, but is nevertheless a programming error that should be detected. + + E.g. the following sequence would write data to the wrong file ([fd2] instead of [fd1]), + and raise no errors at runtime: + {[ + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.close fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.write_substring fd1 "test" 0 4; + Unix.close fd2 + ]} + + This module introduces a lightweight wrapper around {!type:Unix.file_descr}, + and detects attempts to use a file descriptor after it has been closed: + {[ + open Xapi_fdcaps + + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.close_exn fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.with_fd_exn fd1 (fun fd -> Unix.write_substring fd "test" 0 4); + ]} + + It raises {!val:Unix.EBADF}: + {[ Exception: Unix.Unix_error(Unix.EBADF, "unsafe_to_file_descr_exn", "") ]} + + The callback of {!val:with_fd_exn} has access to the underlying {!type:Unix.file_descr}, + and may accidentally call {!val:Unix.close}. + + To detect that {!val:with_fd_exn} calls {!val:Unix.LargeFile.fstat} to check that the file descriptor + remained the "same" after the call. + File descriptors are considered to be the same if their kind, device and inode remain unchanged + (obviously other parts of the stat structure such as timestamps and size may change between calls). + This doesn't detect all bugs, but detects most common bugs + (hardlinked files will still show up as the same but the file position may have been different, which is not checked). + + The extra system calls have an overhead so an unsafe version is available, but not documented (it should only be used internally by other modules in {!mod:Xapi_fdcaps}). + + With the safe wrapper we also have a non-integer type that we can attach a finaliser too. + This is used to detect and close leaked file descriptors safely (by checking that it is "the same" that we originally opened). +*) + +(** a file descriptor that is safe against double close *) +type t + +val of_file_descr : Unix.file_descr -> t +(** [of_file_descr fd] wraps [fd]. + + *) + +val idempotent_close_exn : t -> unit +(** [idempotent_close_exn t] closes [t], and doesn't raise an exception if [t] is already closed. + Other exceptions may still escape (e.g. if the underlying [close] has reported an [ENOSPC] or [EIO] error). +*) + +val close_exn : t -> unit +(** [close_exn t] closes t and raises an exception if [t] is already closed. + + @raises Unix_error(Unix.EBADF,_,_) if [t] is already closed. +*) + +val with_fd_exn : t -> (Unix.file_descr -> 'a) -> 'a +(** [with_fd_exn t f] calls [f fd] with the underlying file descriptor. + [f] must not close [fd]. + + @raises Unix_error(Unix.EBADF,_,_) if the file descriptor is not the same after [f] terminates. +*) + +val nop : t +(** [nop] is a file descriptor that is always closed and no operations are valid on it. *) + +val pp_kind : Format.formatter -> Unix.file_kind -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +val pp : Format.formatter -> t -> unit +(** [pp formatter t] pretty prints information about [t] on [formatter]. *) + +val dump : Format.formatter -> t -> unit +(** [dump formatter t] prints all the debug information available about [t] on [formatter] *) + +(**/**) + +(* For small wrappers and high frequency calls like [read] and [write]. + Should only be used by the wrappers in {!mod:Operations}, hence hidden from the documentation. +*) + +val setup : unit -> unit +(** [setup ()] sets up a [SIGPIPE] handler. + With the handler set up a broken pipe will result in a [Unix.EPIPE] exception instead of killing the program *) + +val leaked : unit -> int +(** [leaked ()] is a count of leaked file descriptors detected. + Run [Gc.full_major ()] to get an accurate count before calling this *) + +(**/**) + +val unsafe_to_file_descr_exn : t -> Unix.file_descr diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune new file mode 100644 index 00000000000..a70e4820c9b --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune @@ -0,0 +1,10 @@ +(tests + (package xapi-stdext-unix) + (names test_safefd test_properties test_operations) + (libraries xapi_fdcaps alcotest fmt) +) + +(cram + (package xapi-stdext-unix) + (deps (package xapi-stdext-unix)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t new file mode 100644 index 00000000000..fa6792fc019 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t @@ -0,0 +1,15 @@ +Check that we get compile errors when trying to use a read-only or write-only property with the opposite operation: + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_readable (make `wronly `reg) + > EOF + $ ocamlfind ocamlc -package xapi-stdext-unix.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-stdext-unix.fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `rdonly diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml new file mode 100644 index 00000000000..fa60e5f6682 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml @@ -0,0 +1,303 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps +open Properties +open Operations +open Syntax + +let b = Bytes.make 256 'x' + +let read_fd fd = + let (_ : int) = read fd b 0 (Bytes.length b) in + () + +let check_unsafe_raises ?(exn = Unix.EBADF) name t op = + (* if we bypass the type safety then we should get an error at runtime, + but only when the capability is 'no', not when it is 'removed' + *) + let fd = For_test.unsafe_fd_exn t in + let msg = Printf.sprintf "%s when <%s: no; ..>" name name in + let exn = Unix.Unix_error (exn, name, "") in + Alcotest.check_raises msg exn @@ fun () -> op fd + +let error_read_fd (t : ([< wronly], _) make) = + let@ fd = check_unsafe_raises "read" t in + let (_ : int) = Unix.read fd b 0 (Bytes.length b) in + () + +let str = "test" + +let write_fd fd = + let (_ : int) = single_write_substring fd str 0 (String.length str) in + () + +let error_write_fd (t : ([< rdonly], _) make) = + let@ fd = check_unsafe_raises "single_write" t in + let (_ : int) = Unix.single_write_substring fd str 0 (String.length str) in + () + +let test_ro fd = read_fd fd ; error_write_fd fd + +let test_wo fd = write_fd fd ; error_read_fd fd + +let test_lseek t = + let actual = lseek t 0L Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"starting position" ~expected:0L ~actual ; + let expected = 17L in + let actual = lseek t expected Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"jump1 position" ~expected ~actual ; + let actual = lseek t 3L Unix.SEEK_CUR in + Alcotest.(check' int64) ~msg:"jump2 position" ~expected:20L ~actual + +let error_lseek (t : (_, [< espipe]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ESPIPE "lseek" t in + let (_ : int) = Unix.lseek fd 0 Unix.SEEK_CUR in + () + +let test_ftruncate t = + let expected = 4000L in + ftruncate t expected ; + let actual = lseek t 0L Unix.SEEK_END in + Alcotest.(check' int64) ~msg:"size after ftruncate" ~expected ~actual + +type not_truncate = [blk | chr | dir | lnk | fifo | sock] + +let error_ftruncate (t : (_, [< not_truncate]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.EINVAL "ftruncate" t in + Unix.LargeFile.ftruncate fd 4000L + +type not_sock = [reg | blk | chr | dir | lnk | fifo] + +let error_shutdown (t : (_, [< not_sock]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ENOTSOCK "shutdown" t in + Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + +let test_fd2 make ops = + ops + |> List.map @@ fun (name, op1, op2) -> + let test () = + let@ fd1, fd2 = with_fd2 @@ make () in + pp Fmt.stdout fd1 ; + dump Fmt.stdout fd1 ; + (* the 2 operations may depend on each-other, e.g. write and read on a pipe, so must be part of same testcase *) + set_nonblock fd1 ; + set_nonblock fd2 ; + op2 fd2 ; + op1 fd1 ; + clear_nonblock fd1 ; + clear_nonblock fd2 + in + Alcotest.(test_case name `Quick) test + +let test_fd with_make ops = + ops + |> List.map @@ fun (name, op) -> + let test () = + let@ fd = with_make () in + op fd + in + Alcotest.(test_case name `Quick) test + +let test_pipe = + test_fd2 pipe + [ + ("wo,ro", test_ro, test_wo) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ; ("error_shutdown", error_shutdown, error_shutdown) + ] + +let test_sock = + let make () = socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + test_fd2 make + [ + ("read,write", read_fd, write_fd) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ] + +let with_fd fd f = pp Fmt.stdout fd ; dump Fmt.stdout fd ; with_fd fd f + +let with_tempfile () f = + let@ name, fd = with_tempfile () in + Fmt.pf Fmt.stdout "%s: %a@." name pp fd ; + f (name, fd) + +let test_single make f () = + let@ t = with_fd @@ make () in + error_shutdown t ; f t + +let test_safe_close () = + let@ t = with_fd @@ dev_null_in () in + close t ; close t + +let test_regular = + let with_make () f = + let@ _name, out = with_tempfile () in + f out + in + test_fd with_make + [ + ("wo", test_wo) + ; ("lseek", test_lseek) + ; ("ftruncate", test_ftruncate) + ; ("error_shutdown", error_shutdown) + ] + +let test_sock_shutdown_r () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + shutdown_recv fd1 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown of other end" exn in + write_fd fd2 + +let test_sock_shutdown_w () = + let@ _fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_send fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + +let test_sock_shutdown_all () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_all fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let () = + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd1 + +let test_block sector_size = + let with_make () f = + let@ name, fd = with_tempfile () in + ftruncate fd 8192L ; + let run () = + try + let@ _blkname, fd = with_temp_blk ~sector_size name in + f fd + with Failure _ -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Failure "with_temp_blk") bt + in + if Unix.geteuid () = 0 then + run () + else + Alcotest.check_raises "non-root fails to create blockdevice" + (Failure "with_temp_blk") run + in + test_fd with_make + [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] + +let test_block_nest = + let with_make () f = + if Unix.geteuid () <> 0 then + Alcotest.skip () ; + let@ name, fd = with_tempfile () in + ftruncate fd 8192L ; + let@ blkname, _fd = with_temp_blk ~sector_size:4096 name in + let@ _blkname, fd = with_temp_blk ~sector_size:512 blkname in + f fd + in + test_fd with_make + [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] + +let test_creat () = + let name = Filename.temp_file __MODULE__ (Unix.getpid () |> string_of_int) in + Unix.unlink name ; + let@ fd1 = with_fd @@ creat name [] 0o600 in + pp Fmt.stdout fd1 ; + read_fd fd1 ; + write_fd fd1 ; + let@ fd2 = with_fd @@ openfile_rw `reg name [] in + pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 + +let test_repeat_read () = + let buf = String.init 255 Char.chr in + let read _ dst off len = + let available = String.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string buf off dst off len ; + len + in + let dst = Bytes.make 300 '_' in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_read read placeholder dst 0 (Bytes.length dst) in + Alcotest.(check' int) ~msg:"amount read" ~actual ~expected:(String.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string dst 0 actual) + ~expected:buf + +let test_repeat_write () = + let buf = Bytes.make 255 '_' in + let write _ src off len = + let available = Bytes.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string src off buf off len ; + len + in + let src = String.init 255 Char.chr in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_write write placeholder src 0 (String.length src) in + Alcotest.(check' int) + ~msg:"amount written" ~actual ~expected:(Bytes.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string buf 0 actual) + ~expected:src + +let tests = + Alcotest. + [ + test_case "/dev/null in" `Quick @@ test_single dev_null_in test_ro + ; test_case "/dev/null out" `Quick @@ test_single dev_null_out test_wo + ; test_case "/dev/zero" `Quick @@ test_single dev_zero test_ro + ; test_case "safe close" `Quick test_safe_close + ; test_case "socket shutdown read" `Quick test_sock_shutdown_r + ; test_case "socket shutdown write" `Quick test_sock_shutdown_w + ; test_case "socket shutdown both" `Quick test_sock_shutdown_all + ; test_case "create" `Quick test_creat + ; test_case "repeat_read" `Quick test_repeat_read + ; test_case "repeat_write" `Quick test_repeat_write + ] + +(* this must be the last test *) +let test_no_leaks () = + Gc.full_major () ; + Alcotest.(check' int) + ~msg:"Check for no FD leaks" ~expected:0 ~actual:(Safefd.leaked ()) + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("pipe", test_pipe) + ; ("socket", test_sock) + ; ("regular", test_regular) + ; ("block 512", test_block 512) + ; ("block 4k", test_block 4096) + ; ("block 512 on 4k", test_block_nest) + ; ("xapi_fdcaps", tests) + ; ("no fd leaks", [Alcotest.test_case "no leaks" `Quick test_no_leaks]) + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml new file mode 100644 index 00000000000..e72e179af51 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml @@ -0,0 +1,94 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps.Properties + +(* compilation tests, failed ones are in [properties.t] *) +let () = + let (_ : (_, _) t) = as_readable (make `rdonly `reg) in + let (_ : (_, _) t) = as_writable (make `wronly `reg) in + let (_ : (_, _) t) = as_readable (make `rdwr `reg) in + let (_ : (_, _) t) = as_writable (make `rdwr `reg) in + let #espipe = `fifo in + let #espipe = `sock in + let #seekable = `reg in + let #seekable = `blk in + let #truncatable = `reg in + () + +(* test that unification works *) +let _any_file = function + | 0 -> + make `rdonly `reg + | 1 -> + make `rdonly `blk + | 2 -> + make `rdonly `chr + | 3 -> + make `rdonly `dir + | 4 -> + make `rdonly `sock + | _ -> + make `rdonly `fifo + +let all_rw = [`rdonly; `wronly; `rdwr] + +let test_as_rw_opt f expected_set = + let t = Alcotest.testable pp ( = ) in + all_rw + |> List.map @@ fun rw -> + let test () = + let prop = make rw `reg in + let expected = if List.mem rw expected_set then Some prop else None in + let msg = Fmt.str "as_%a_opt" pp_rw rw in + Alcotest.(check' @@ option t) ~msg ~expected ~actual:(f prop) + in + Alcotest.test_case (Fmt.to_to_string pp_rw rw) `Quick test + +let _test_pp prop = Alcotest.test_case (Fmt.to_to_string pp prop) `Quick ignore + +let all_kinds = [`reg; `blk; `chr; `dir; `lnk; `sock; `fifo] + +let test_to_unix_kind () = + let all_unix_kinds = + List.sort_uniq compare @@ all_kinds |> List.map to_unix_kind + in + Alcotest.(check' int) + ~msg:"to_unix_kind mapping is unique" ~expected:(List.length all_kinds) + ~actual:(List.length all_unix_kinds) + +let test_as_kind = + let t = Alcotest.testable pp ( = ) in + all_kinds + |> List.map @@ fun k1 -> + ( Fmt.str "as_kind_opt %a" pp_kind k1 + , all_kinds + |> List.map @@ fun k2 -> + let test () = + let prop = make `rdonly k2 in + let actual = as_kind_opt k1 prop in + let expected = if k1 = k2 then Some prop else None in + Alcotest.(check' @@ option t) ~msg:"as_kind_opt" ~expected ~actual + in + Alcotest.test_case (Fmt.to_to_string pp_kind k2) `Quick test + ) + +let tests = + let open Alcotest in + ("to_unix_kind", [test_case "to_unix_kind" `Quick test_to_unix_kind]) + :: ("as_readable_opt", test_as_rw_opt as_readable_opt [`rdonly; `rdwr]) + :: ("as_writable_opt", test_as_rw_opt as_writable_opt [`wronly; `rdwr]) + :: test_as_kind + +let () = Alcotest.run ~show_errors:true "test_capabilities" tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml new file mode 100644 index 00000000000..ea1b1343410 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml @@ -0,0 +1,123 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Xapi_fdcaps +open Safefd + +let make_safefd () = + let rd, wr = Unix.pipe ~cloexec:true () in + (of_file_descr rd, of_file_descr wr) + +let test_safefd_regular () = + let rd, wr = Unix.pipe ~cloexec:true () in + let rd, wr = (of_file_descr rd, of_file_descr wr) in + let (_ : Unix.LargeFile.stats) = with_fd_exn rd Unix.LargeFile.fstat + and (_ : Unix.LargeFile.stats) = with_fd_exn wr Unix.LargeFile.fstat in + close_exn rd ; close_exn wr + +let test_safefd_double_close () = + let rd, wr = make_safefd () in + close_exn rd ; + close_exn wr ; + let exn = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "double close" exn (fun () -> close_exn wr) + +let test_safefd_idempotent_close () = + let rd, wr = make_safefd () in + close_exn rd ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr + +let test_safefd_unix_close () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "fstat", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr Unix.close + ) + +let remove_unix_error_arg f = + try f () + with Unix.Unix_error (code, fn, _) -> + (* remove arg, so we can match with [Alcotest.check_raises] *) + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Unix.Unix_error (code, fn, "")) bt + +let with_fd_exn f arg = remove_unix_error_arg (fun () -> with_fd_exn f arg) + +let close_reuse fd = + Unix.close fd ; + (* open and leak fd, this should reuse the FD number of [fd], but we should be able to detect via stat *) + let _, _ = Unix.pipe () in + () + +let test_safefd_unix_close_reuse () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "with_fd_exn", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr close_reuse + ) + +let leak () = + let rd, wr = make_safefd () in + close_exn rd ; + (* leak wr *) + unsafe_to_file_descr_exn wr + +let test_safefd_finalised () = + let _leaked_fd : Unix.file_descr = leak () in + Gc.full_major () ; + Alcotest.( + check' int ~msg:"leak detected" ~expected:2 ~actual:(Safefd.leaked ()) + ) + +let test_pp_and_dump () = + let a, b = make_safefd () in + Format.printf "a: %a@,b: %a@." Safefd.pp a Safefd.pp b ; + Format.printf "a: %a@,b: %a@." Safefd.dump a Safefd.dump b + +let test_nop () = + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "nop close raises" ebadf (fun () -> close_exn nop) + +let test_unsafe_closed () = + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + dump Fmt.stdout nop ; + Alcotest.check_raises "unsafe raises" ebadf (fun () -> + let (_ : Unix.file_descr) = unsafe_to_file_descr_exn nop in + () + ) + +let tests_safefd = + Alcotest. + [ + test_case "nop" `Quick test_nop + ; test_case "regular ops" `Quick test_safefd_regular + ; test_case "double close detected" `Quick test_safefd_double_close + ; test_case "idempotent close" `Quick test_safefd_idempotent_close + ; test_case "Unix.close detected" `Quick test_safefd_unix_close + ; test_case "Unix.close detected after reuse" `Quick + test_safefd_unix_close_reuse + ; test_case "FD leak detected" `Quick test_safefd_finalised + ; test_case "test pp and dump" `Quick test_pp_and_dump + ; test_case "unsafe of closed fd" `Quick test_unsafe_closed + ] + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" [("safefd", tests_safefd)] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index fe2cc6dd85a..f7e9141c3a9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -1,8 +1,16 @@ (library (public_name xapi-stdext-threads) (name xapi_stdext_threads) + (modules :standard \ threadext_test) (libraries threads.posix unix + xapi-stdext-unix xapi-stdext-pervasives) ) +(test + (name threadext_test) + (package xapi-stdext-threads) + (modules threadext_test) + (libraries xapi_stdext_threads alcotest mtime.clock.os mtime fmt) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index 56025d51154..ef30cfb5ba4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -86,11 +86,15 @@ module Delay = struct pipe_out ) in - let r, _, _ = Unix.select [pipe_out] [] [] seconds in + let open Xapi_stdext_unix.Unixext in (* flush the single byte from the pipe *) - if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; + try + let (_ : string) = + time_limited_single_read pipe_out 1 ~max_wait:seconds + in + false + with Timeout -> true (* return true if we waited the full length of time, false if we were woken *) - r = [] with Pre_signalled -> false ) (fun () -> diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml new file mode 100644 index 00000000000..c21cd62e8c0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Delay = Xapi_stdext_threads.Threadext.Delay + +let span_approx ~max_error = + let eq_within a b = + let diff = Mtime.Span.abs_diff a b in + Mtime.Span.compare diff max_error < 0 + in + Alcotest.testable Mtime.Span.pp @@ eq_within + +let test_wait () = + let m = Delay.make () in + let c = Mtime_clock.counter () in + let time = 1 in + let expected = Mtime.Span.(time * s) in + let max_error = Mtime.Span.(10 * ms) in + let _ = Delay.wait m (float_of_int time) in + let wait_time = Mtime_clock.count c in + Alcotest.check' (span_approx ~max_error) ~msg:"diff is smaller than max error" + ~expected ~actual:wait_time + +let () = Alcotest.run "Threadext" [("wait", [("wait", `Quick, test_wait)])] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune index de5c2339c15..92b77753a86 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune @@ -3,8 +3,11 @@ (public_name xapi-stdext-unix) (libraries fd-send-recv + integers + polly unix xapi-backtrace + threads.posix unix-errno unix-errno.unix astring diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 0daefb52153..407d025a8a8 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,6 +1,23 @@ -(executable +(test + (name unixext_test) + (package xapi-stdext-unix) + (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)) +) + +(test (modes exe) (name test_systemd) + (package xapi-stdext-unix) + (modules test_systemd) (libraries xapi-stdext-unix)) (cram 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..e0f2726f303 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -0,0 +1,196 @@ +open QCheck2 +open Xapi_stdext_unix +open Xapi_fd_test + +let expect_string ~expected ~actual = + if not (String.equal expected actual) then + Test.fail_reportf "Data sent and observed do not match: %S <> %S" expected + actual + +let expect_amount ~expected observation = + let open Observations in + let actual = String.length observation.data in + if expected <> actual then + Test.fail_reportf + "Amount of data available and transferred does not match: %d <> %d;@,%a" + expected actual pp observation + +let skip_blk = function + | Unix.S_BLK -> + if Unix.geteuid () <> 0 then + QCheck2.assume_fail () + | _ -> + () + +let skip_dirlnk = function + | Unix.S_DIR | Unix.S_LNK -> + QCheck2.assume_fail () + | _ -> + () + +(* +let pp_pair = + let open Observations in + Fmt.(record + [ field "read" (fun t -> t.read) pp + ; field "write" (fun t -> t.write) pp + ; field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ] + ) +*) + +let test_time_limited_write = + let gen = Gen.tup2 Generate.t Generate.timeouts + and print = Print.tup2 Generate.print Print.float in + Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> + skip_blk behaviour.kind ; + skip_dirlnk behaviour.kind ; + try + let test_elapsed = ref Mtime.Span.zero in + let test wrapped_fd = + let len = behaviour.size in + let buf = String.init len (fun i -> Char.chr (i mod 255)) in + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + Unix.set_nonblock fd ; + let dt = Mtime_clock.counter () in + let deadline = Unix.gettimeofday () +. timeout in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Unixext.time_limited_write_substring fd len buf deadline + ) ; + buf + in + (*Printf.eprintf "testing write: %s\n%!" (print (behaviour, timeout)) ;*) + let observations, result = Generate.run_wo behaviour ~f:test in + let () = + let open Observations in + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s > timeout +. 0.5 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %f > %f; %s" + elapsed_s timeout + (Fmt.to_to_string Fmt.(option pp) observations.Observations.read) ; + match (observations, result) with + | {read= Some read; _}, Ok expected -> + (* expected is the input given to [time_limited_write_substring] *) + expect_amount ~expected:(String.length expected) read ; + expect_string ~expected ~actual:read.data + | {read= Some read; _}, Error (`Exn_trap (Unixext.Timeout, _)) -> + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s < timeout then + Test.fail_reportf "Timed out earlier than requested: %f < %f" + elapsed_s timeout ; + let actual = String.length read.data in + if actual >= behaviour.size then + Test.fail_reportf "Timed out, but transferred enough data: %d >= %d" + actual behaviour.size + | ( {read= Some read; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length read.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {read= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + with e -> + Format.eprintf "Error: %a@." Fmt.exn_backtrace + (e, Printexc.get_raw_backtrace ()) ; + false + +let test_time_limited_read = + let gen = Gen.tup2 Generate.t Generate.timeouts + and print = Print.tup2 Generate.print Print.float in + Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> + (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) + skip_blk behaviour.kind ; + skip_dirlnk behaviour.kind ; + let test_elapsed = ref Mtime.Span.zero in + let test wrapped_fd = + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + Unix.set_nonblock fd ; + let dt = Mtime_clock.counter () in + let deadline = Unix.gettimeofday () +. timeout in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Unixext.time_limited_read fd behaviour.size deadline + ) + in + (*Printf.eprintf "testing: %s\n%!" (print (behaviour, timeout)) ;*) + let observations, result = + let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in + Generate.run_ro behaviour buf ~f:test + in + let () = + let open Observations in + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s > timeout +. 0.5 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %f > %f; %s" elapsed_s + timeout + (Fmt.to_to_string Fmt.(option pp) observations.Observations.write) ; + (* Format.eprintf "Result: %a@." (Fmt.option Observations.pp) observations.write;*) + match (observations, result) with + | {write= Some write; _}, Ok actual -> + expect_amount ~expected:(String.length actual) write ; + expect_string ~expected:write.data ~actual + | {write= Some _; _}, Error (`Exn_trap (Unixext.Timeout, _)) -> + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s < timeout then + Test.fail_reportf "Timed out earlier than requested: %f < %f" + elapsed_s timeout + | ( {write= Some write; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length write.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {write= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + +let test_proxy = + let gen = Generate.t and print = Generate.print in + Test.make ~name:__FUNCTION__ ~print gen @@ fun behaviour -> + if behaviour.kind <> Unix.S_SOCK then + QCheck2.assume_fail () ; + let test wrapped_fd = + let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + let test2 wrapped_fd2 = + let fd2 = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd2 in + Unixext.proxy (Unix.dup fd) (Unix.dup fd2) + in + match Generate.run_rw behaviour buf ~f:test2 with + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + | obs, Ok () -> + obs + in + let buf' = + String.init behaviour.size (fun i -> Char.chr ((30 + i) mod 255)) + in + match Generate.run_rw behaviour buf' ~f:test with + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + | {read= None; _}, Ok _ -> + false + | _, Ok {write= None; _} -> + false + | {read= Some write; _}, Ok {write= Some read; _} -> + expect_string ~expected:write.data ~actual:read.data ; + true + +let tests = [test_proxy; test_time_limited_write; test_time_limited_read] + +let () = + (* avoid SIGPIPE *) + let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in + Xapi_stdext_unix.Unixext.test_open 1024 ; + QCheck_base_runner.run_tests_main tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 1b264b04602..ae2c92dc87b 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -383,7 +383,7 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = let cmdline = readcmdline pid in if cmdline = reference then ( (* still up, let's sleep a bit *) - ignore (Unix.select [] [] [] loop_time_waiting) ; + Thread.delay loop_time_waiting ; left := !left -. loop_time_waiting ) else (* not the same, it's gone ! *) quit := true @@ -422,6 +422,11 @@ let string_of_signal x = else Printf.sprintf "(ocaml signal %d with an unknown name)" x +let with_polly f = + let polly = Polly.create () in + let finally () = Polly.close polly in + Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> f polly) finally + let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let size = 64 * 1024 in (* [a'] is read from [a] and will be written to [b] *) @@ -429,24 +434,38 @@ let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let a' = CBuf.empty size and b' = CBuf.empty size in Unix.set_nonblock a ; Unix.set_nonblock b ; + with_polly @@ fun polly -> + Polly.add polly a Polly.Events.empty ; + Polly.add polly b Polly.Events.empty ; try while true do - let r = - (if CBuf.should_read a' then [a] else []) - @ if CBuf.should_read b' then [b] else [] - in - let w = - (if CBuf.should_write a' then [b] else []) - @ if CBuf.should_write b' then [a] else [] + (* use oneshot notification so that we can use Polly.mod as needed to reenable, + but it will disable itself each turn *) + let a_events = + Polly.Events.( + (if CBuf.should_read a' then inp lor oneshot else empty) + lor if CBuf.should_write b' then out lor oneshot else empty + ) + and b_events = + Polly.Events.( + (if CBuf.should_read b' then inp lor oneshot else empty) + lor if CBuf.should_write a' then out lor oneshot else empty + ) in (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file ; - let r, w, _ = Unix.select r w [] (-1.0) in - (* Do the writing before the reading *) - List.iter - (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) - w ; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; + if Polly.Events.(a_events lor b_events = empty) then raise End_of_file ; + + if Polly.Events.(a_events <> empty) then + Polly.upd polly a a_events ; + if Polly.Events.(b_events <> empty) then + Polly.upd polly b b_events ; + Polly.wait_fold polly 4 (-1) () (fun _polly fd events () -> + (* Do the writing before the reading *) + if Polly.Events.(test out events) then + if a = fd then CBuf.write b' a else CBuf.write a' b ; + if Polly.Events.(test inp events) then + if a = fd then CBuf.read a' a else CBuf.read b' b + ) ; (* If there's nothing else to read or write then signal the other end *) List.iter (fun (buf, fd) -> @@ -528,32 +547,69 @@ let really_read_string fd length = exception Timeout +let to_milliseconds ms = ms *. 1000. |> ceil |> int_of_float + +(* Allocating a new polly and waiting like this results in at least 3 syscalls. + An alternative for sockets would be to use [setsockopt], + but that would need 3 system calls too: + + [fstat] to check that it is not a pipe + (you'd risk getting stuck forever without [select/poll/epoll] there) + [setsockopt_float] to set the timeout + [clear_nonblock] to ensure the socket is non-blocking +*) +let with_polly_wait kind fd f = + match Unix.(LargeFile.fstat fd).st_kind with + | S_DIR -> + failwith "File descriptor cannot be a directory for read/write" + | S_LNK -> + (* should never happen, the file is already open and OCaml doesn't support O_SYMLINK to open the link itself *) + failwith "cannot read/write into a symbolic link" + | S_REG | S_BLK -> + (* the best we can do is to split up the read/write operation into 64KiB chunks, + and check the timeout after each chunk. + select() would've silently succeeded here, whereas epoll() is stricted and returns EPERM + *) + let wait remaining_time = if remaining_time < 0. then raise Timeout in + f wait fd + | S_CHR | S_FIFO | S_SOCK -> + with_polly @@ fun polly -> + Polly.add polly fd kind ; + let wait remaining_time = + let milliseconds = to_milliseconds remaining_time in + if milliseconds <= 0 then raise Timeout ; + let ready = + Polly.wait polly 1 milliseconds @@ fun _ event_on_fd _ -> + assert (event_on_fd = fd) + in + if ready = 0 then raise Timeout + in + f wait fd + (* Write as many bytes to a file descriptor as possible from data before a given clock time. *) (* Raises Timeout exception if the number of bytes written is less than the specified length. *) (* Writes into the file descriptor at the current cursor position. *) let time_limited_write_internal (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data target_response_time = + with_polly_wait Polly.Events.out filedesc @@ fun wait filedesc -> let total_bytes_to_write = length in let bytes_written = ref 0 in let now = ref (Unix.gettimeofday ()) in while !bytes_written < total_bytes_to_write && !now < target_response_time do let remaining_time = target_response_time -. !now in - let _, ready_to_write, _ = Unix.select [] [filedesc] [] remaining_time in - (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) - ( if List.mem filedesc ready_to_write then - let bytes_to_write = total_bytes_to_write - !bytes_written in - let bytes = - try write filedesc data !bytes_written bytes_to_write - with - | Unix.Unix_error (Unix.EAGAIN, _, _) - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) - -> - 0 - in - (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) - bytes_written := bytes + !bytes_written - ) ; + wait remaining_time ; + let bytes_to_write = total_bytes_to_write - !bytes_written in + let bytes = + try write filedesc data !bytes_written bytes_to_write + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + bytes_written := bytes + !bytes_written ; now := Unix.gettimeofday () done ; if !bytes_written = total_bytes_to_write then @@ -562,40 +618,39 @@ let time_limited_write_internal raise Timeout let time_limited_write filedesc length data target_response_time = - time_limited_write_internal Unix.write filedesc length data + time_limited_write_internal Unix.single_write filedesc length data target_response_time let time_limited_write_substring filedesc length data target_response_time = - time_limited_write_internal Unix.write_substring filedesc length data + time_limited_write_internal Unix.single_write_substring filedesc length data target_response_time (* Read as many bytes to a file descriptor as possible before a given clock time. *) (* Raises Timeout exception if the number of bytes read is less than the desired number. *) (* Reads from the file descriptor at the current cursor position. *) let time_limited_read filedesc length target_response_time = + with_polly_wait Polly.Events.inp filedesc @@ fun wait filedesc -> let total_bytes_to_read = length in let bytes_read = ref 0 in let buf = Bytes.make total_bytes_to_read '\000' in let now = ref (Unix.gettimeofday ()) in while !bytes_read < total_bytes_to_read && !now < target_response_time do let remaining_time = target_response_time -. !now in - let ready_to_read, _, _ = Unix.select [filedesc] [] [] remaining_time in - ( if List.mem filedesc ready_to_read then - let bytes_to_read = total_bytes_to_read - !bytes_read in - let bytes = - try Unix.read filedesc buf !bytes_read bytes_to_read - with - | Unix.Unix_error (Unix.EAGAIN, _, _) - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) - -> - 0 - in - (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) - if bytes = 0 then - raise End_of_file (* End of file has been reached *) - else - bytes_read := bytes + !bytes_read - ) ; + wait remaining_time ; + let bytes_to_read = total_bytes_to_read - !bytes_read in + let bytes = + try Unix.read filedesc buf !bytes_read bytes_to_read + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) + if bytes = 0 then + raise End_of_file (* End of file has been reached *) + else + bytes_read := bytes + !bytes_read ; now := Unix.gettimeofday () done ; if !bytes_read = total_bytes_to_read then @@ -603,6 +658,20 @@ let time_limited_read filedesc length target_response_time = else (* we ran out of time *) raise Timeout +let time_limited_single_read filedesc length ~max_wait = + let buf = Bytes.make length '\000' in + with_polly_wait Polly.Events.inp filedesc @@ fun wait filedesc -> + wait max_wait ; + let bytes = + try Unix.read filedesc buf 0 length + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + Bytes.sub_string buf 0 bytes + (* --------------------------------------------------------------------------------------- *) (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) @@ -789,6 +858,23 @@ let domain_of_addr str = Some (Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, 1))) with _ -> None +let test_open_called = Atomic.make false + +let test_open n = + if not (Atomic.compare_and_set test_open_called false true) then + invalid_arg "test_open can only be called once" ; + (* we could make this conditional on whether ulimit was increased or not, + but that could hide bugs if we think the CI has tested this, but due to ulimit it hasn't. + *) + if n > 0 then ( + let socket = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + at_exit (fun () -> Unix.close socket) ; + for _ = 2 to n do + let fd = Unix.dup socket in + at_exit (fun () -> Unix.close fd) + done + ) + module Direct = struct type t = Unix.file_descr 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 9f3c06390d1..176adc94cf8 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 @@ -245,6 +248,17 @@ val statvfs : string -> statvfs_t val domain_of_addr : string -> Unix.socket_domain option (** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) +val test_open : int -> unit +(** [test_open n] opens n file descriptors. This is useful for testing that the application makes no calls + to [Unix.select] that use file descriptors, because such calls will then immediately fail. + + This assumes that [ulimit -n] has been suitably increased in the test environment. + + Can only be called once in a program, and will raise an exception otherwise. + + The file descriptors will stay open until the program exits. + *) + module Direct : sig (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) diff --git a/ocaml/message-switch/async/dune b/ocaml/message-switch/async/dune index a0a1beb8c19..89f2c3a5ff4 100644 --- a/ocaml/message-switch/async/dune +++ b/ocaml/message-switch/async/dune @@ -2,14 +2,15 @@ (name message_switch_async) (public_name message-switch-async) (libraries - async - async_unix + (re_export async) + (re_export async_unix) async_kernel base cohttp-async - core + (re_export core) core_unix core_kernel + core_unix.time_unix message-switch-core ) ) diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune index 6debbc895c7..41cbf9e9f2d 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -8,6 +8,7 @@ rpclib.json sexplib sexplib0 + threads.posix uri xapi-log xapi-stdext-threads diff --git a/ocaml/message-switch/core_test/async/dune b/ocaml/message-switch/core_test/async/dune index 2891908317e..6e690c35e1d 100644 --- a/ocaml/message-switch/core_test/async/dune +++ b/ocaml/message-switch/core_test/async/dune @@ -13,6 +13,8 @@ cohttp-async core core_kernel + core_unix + core_unix.time_unix message-switch-async ) ) diff --git a/ocaml/message-switch/lwt/dune b/ocaml/message-switch/lwt/dune index 2aaf432952b..12f03301298 100644 --- a/ocaml/message-switch/lwt/dune +++ b/ocaml/message-switch/lwt/dune @@ -4,8 +4,8 @@ (libraries cohttp-lwt-unix message-switch-core - lwt - lwt.unix + (re_export lwt) + (re_export lwt.unix) ) ) diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 380345b1b2d..51840f8e471 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -7,6 +7,8 @@ alcotest astring dune-build-info + ezxenstore + ezxenstore.watch fmt forkexec http_lib @@ -35,3 +37,8 @@ (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) ) + +(rule + (alias runtest) + (action (run ./quicktest.exe -skip-xapi -- list)) +) diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml index d390f0dfc38..7485cef15d4 100644 --- a/ocaml/quicktest/qt.ml +++ b/ocaml/quicktest/qt.ml @@ -58,7 +58,11 @@ let inventory_lookup k = Xapi_inventory.inventory_filename := "/etc/xensource-inventory" ; Xapi_inventory.lookup k -let localhost_uuid = inventory_lookup Xapi_inventory._installation_uuid +let localhost_uuid = + if Unix.geteuid () = 0 then + inventory_lookup Xapi_inventory._installation_uuid + else + Uuidm.nil |> Uuidm.to_string module Test = struct let assert_raises_match exception_match fn = diff --git a/ocaml/quicktest/qt_filter.ml b/ocaml/quicktest/qt_filter.ml index cd6933db98c..744b0545a16 100644 --- a/ocaml/quicktest/qt_filter.ml +++ b/ocaml/quicktest/qt_filter.ml @@ -76,10 +76,20 @@ let cleanup () = Client.Client.Session.logout ~rpc:!A.rpc ~session_id:!session_id let wrap f = - init () ; - Xapi_stdext_pervasives.Pervasiveext.finally - (fun () -> f () ; finish ()) - cleanup + if !Quicktest_args.skip_xapi then + f () + else ( + init () ; + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f () ; finish ()) + cleanup + ) + +let with_xapi_query f = + if !Quicktest_args.skip_xapi then + [] + else + f () let conn tcs = for_each @@ -317,7 +327,7 @@ module SR = struct let test = test sr_info in (name, speed, test) - let list_srs srs = srs () + let list_srs srs = with_xapi_query srs let f srs tcs = for_each @@ -329,6 +339,7 @@ let sr = SR.f let vm_template template_name = for_each (fun (name, speed, test) -> + with_xapi_query @@ fun () -> match Qt.VM.Template.find !A.rpc !session_id template_name with | None -> [] diff --git a/ocaml/quicktest/qt_filter.mli b/ocaml/quicktest/qt_filter.mli index 8fdf1003f09..ba8a7416358 100644 --- a/ocaml/quicktest/qt_filter.mli +++ b/ocaml/quicktest/qt_filter.mli @@ -20,6 +20,10 @@ val wrap : (unit -> unit) -> unit (** This has to wrap the quicktest run *) +val with_xapi_query : (unit -> 'a list) -> 'a list +(** [with_xapi_query get_list] calls [get_list ()] unless [-skip-xapi] CLI + argument was used. *) + (** A slightly different definition of Alcotest.test_case, to ensure we can reason about the entire type of the test function *) type 'a test_case = string * Alcotest.speed_level * 'a diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index b4ca5725dc6..9300eaa4bd0 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -20,6 +20,7 @@ let () = let suite = [ ("Quicktest_example", Quicktest_example.tests ()) + ; ("xenstore", Quicktest_xenstore.tests ()) ; ("cbt", Quicktest_cbt.tests ()) ; ("event", Quicktest_event.tests ()) ; ("import_raw_vdi", Quicktest_import_raw_vdi.tests ()) diff --git a/ocaml/quicktest/quicktest_args.ml b/ocaml/quicktest/quicktest_args.ml index da394f1fd27..85a4d914c60 100644 --- a/ocaml/quicktest/quicktest_args.ml +++ b/ocaml/quicktest/quicktest_args.ml @@ -35,6 +35,12 @@ let rpc_unix_domain xml = let rpc = ref rpc_unix_domain +let alcotest_args = ref [||] + +let set_alcotest_args l = alcotest_args := Array.of_list l + +let skip_xapi = ref false + (** Parse the legacy quicktest command line args. This is used instead of invoking Alcotest directly, for backwards-compatibility with clients who run the quicktest binary. *) @@ -56,6 +62,8 @@ let parse () = , "Only run SR tests on the specified SR, mutually exclusive with \ -default-sr" ) + ; ("-skip-xapi", Arg.Set skip_xapi, "SKIP tests that require XAPI") + ; ("--", Arg.Rest_all set_alcotest_args, "Supply alcotest arguments") ] (fun x -> match (!host, !username, !password) with @@ -82,4 +90,4 @@ let parse () = let get_alcotest_args () = let name = [|Sys.argv.(0)|] in let colour = if not !use_colour then [|"--color=never"|] else [||] in - Array.concat [name; colour] + Array.concat [name; colour; !alcotest_args] diff --git a/ocaml/quicktest/quicktest_xenstore.ml b/ocaml/quicktest/quicktest_xenstore.ml new file mode 100644 index 00000000000..9ef1114c104 --- /dev/null +++ b/ocaml/quicktest/quicktest_xenstore.ml @@ -0,0 +1,63 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +let test_basic () = + let open Ezxenstore_core.Xenstore in + let result = with_xs (fun xs -> xs.write "/foo" "bar" ; xs.read "/foo") in + if result <> "bar" then + Alcotest.failf "Bad xenstore reply: %S" result + +let test_watch_within_timeout () = + let open Ezxenstore_core in + Xenstore.with_xs @@ fun xs -> + let key = "/towatch" in + xs.rm key ; + let expected = "valuewritten" in + let t = Thread.create (fun (xs : Xenstore.xsh) -> xs.write key expected) xs in + let finally () = Thread.join t in + Fun.protect ~finally @@ fun () -> + let watch = Watch.value_to_appear key in + let actual = Ezxenstore_core.Watch.wait_for ~xs ~timeout:5.0 watch in + Alcotest.check' Alcotest.string ~expected ~actual + ~msg:"xenstore value matches" + +let test_watch_exceed_timeout () = + let open Ezxenstore_core in + Xenstore.with_xs @@ fun xs -> + let key = "/towatch2" in + xs.rm key ; + let expected = "valuewritten" in + let timeout = 0.3 in + let t = + Thread.create + (fun (xs : Xenstore.xsh) -> + Unix.sleepf (2. *. timeout) ; + xs.write key expected + ) + xs + in + let finally () = Thread.join t in + Fun.protect ~finally @@ fun () -> + let watch = Watch.value_to_appear key in + Alcotest.check_raises "timeout" (Ezxenstore_core.Watch.Timeout timeout) + @@ fun () -> + let (_actual : string) = Ezxenstore_core.Watch.wait_for ~xs ~timeout watch in + () + +let tests () = + [ + ("basic", `Quick, test_basic) + ; ("watch_within_timeout", `Quick, test_watch_within_timeout) + ; ("watch_exceed_timeout", `Quick, test_watch_exceed_timeout) + ] diff --git a/ocaml/quicktest/quicktest_xenstore.mli b/ocaml/quicktest/quicktest_xenstore.mli new file mode 100644 index 00000000000..677cf8346a4 --- /dev/null +++ b/ocaml/quicktest/quicktest_xenstore.mli @@ -0,0 +1 @@ +val tests : unit -> (unit -> unit) Qt_filter.test_case list diff --git a/ocaml/sdk-gen/common/dune b/ocaml/sdk-gen/common/dune index 7cda0194598..71ac6f30230 100644 --- a/ocaml/sdk-gen/common/dune +++ b/ocaml/sdk-gen/common/dune @@ -5,6 +5,7 @@ astring xapi-datamodel mustache + xapi-stdext-std ) (modules_without_implementation license) ) diff --git a/ocaml/sdk-gen/go/dune b/ocaml/sdk-gen/go/dune index 75c98f0d0b6..7303bc0c438 100644 --- a/ocaml/sdk-gen/go/dune +++ b/ocaml/sdk-gen/go/dune @@ -16,8 +16,11 @@ (modules gen_go_helper) (libraries CommonFunctions - mustache - xapi-datamodel + astring + (re_export mustache) + (re_export xapi-consts) + (re_export xapi-datamodel) + xapi-stdext-std ) ) @@ -34,7 +37,7 @@ (name test_gen_go) (package xapi-sdk) (modules test_gen_go) - (libraries alcotest xapi-test-utils gen_go_helper) + (libraries CommonFunctions alcotest fmt xapi-test-utils gen_go_helper) (deps (source_tree test_data) (source_tree templates) 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/squeezed/src/squeeze_xen.ml b/ocaml/squeezed/src/squeeze_xen.ml index 496e7d03ea0..31bac6df75b 100644 --- a/ocaml/squeezed/src/squeeze_xen.ml +++ b/ocaml/squeezed/src/squeeze_xen.ml @@ -583,7 +583,7 @@ let make_host ~verbose ~xc = 1024L <> 0L do - ignore (Unix.select [] [] [] 0.25) + Thread.delay 0.25 done ; (* Some VMs are considered by us (but not by xen) to have an @@ -859,7 +859,7 @@ let io ~xc ~verbose = (fun domid kib -> execute_action ~xc {Squeeze.action_domid= domid; new_target_kib= kib} ) - ; wait= (fun delay -> ignore (Unix.select [] [] [] delay)) + ; wait= (fun delay -> Thread.delay delay) ; execute_action= (fun action -> execute_action ~xc action) ; target_host_free_mem_kib ; free_memory_tolerance_kib 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 126b522e151..ef0778ce51c 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,28 +105,34 @@ (modes exe) (package xapi) (modules test_storage_smapiv1_wrapper) -(libraries alcotest xapi_internal fmt)) +(libraries alcotest xapi_internal fmt xapi-idl.storage.interface xapi-idl.storage.interface.types)) (test (name test_storage_quicktest) (modes exe) (package xapi) (modules test_storage_quicktest) -(libraries xapi_internal crowbar)) +(libraries xapi_internal crowbar xapi-idl.storage.interface.types)) (test (name test_ref) (modes exe) (package xapi) (modules test_ref) -(libraries xapi_internal crowbar)) +(libraries + crowbar + fmt + uuidm + xapi-types + xapi_internal +)) (test (name test_observer) (package xapi) -(modules test_observer) (modes (best exe)) -(libraries alcotest tracing xapi_internal tests_common yojson)) +(modules test_observer) +(libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std xapi-tracing-export)) (rule (alias runtest) diff --git a/ocaml/tests/record_util/dune b/ocaml/tests/record_util/dune new file mode 100644 index 00000000000..a91a104da5c --- /dev/null +++ b/ocaml/tests/record_util/dune @@ -0,0 +1,6 @@ +(test + (name test_record_util) + (package xapi) + (libraries alcotest xapi_cli_server rpclib.core xapi_consts xapi_types astring fmt) + (action (run %{test} --show-errors)) +) diff --git a/ocaml/tests/record_util/old_enum_all.ml b/ocaml/tests/record_util/old_enum_all.ml new file mode 100644 index 00000000000..8c5b422365c --- /dev/null +++ b/ocaml/tests/record_util/old_enum_all.ml @@ -0,0 +1,291 @@ +let all_certificate_type = [`ca; `host; `host_internal] + +let all_cluster_host_operation = [`enable; `disable; `destroy] + +let all_cluster_operation = [`add; `remove; `enable; `disable; `destroy] + +let all_vusb_operations = [`attach; `plug; `unplug] + +let all_sdn_controller_protocol = [`ssl; `pssl] + +let all_pvs_proxy_status = + [ + `stopped + ; `initialised + ; `caching + ; `incompatible_write_cache_mode + ; `incompatible_protocol_version + ] + +let all_vgpu_type_implementation = + [`passthrough; `nvidia; `nvidia_sriov; `gvt_g; `mxgpu] + +let all_allocation_algorithm = [`breadth_first; `depth_first] + +let all_pgpu_dom0_access = + [`enabled; `disable_on_reboot; `disabled; `enable_on_reboot] + +let all_sriov_configuration_mode = [`sysfs; `modprobe; `manual; `unknown] + +let all_tunnel_protocol = [`gre; `vxlan] + +let all_cls = + [`VM; `Host; `SR; `Pool; `VMPP; `VMSS; `PVS_proxy; `VDI; `Certificate] + +let all_console_protocol = [`vt100; `rfb; `rdp] + +let all_persistence_backend = [`xapi] + +let all_vtpm_operations = [`destroy] + +let all_vbd_mode = [`RO; `RW] + +let all_vbd_type = [`CD; `Disk; `Floppy] + +let all_vbd_operations = + [`attach; `eject; `insert; `plug; `unplug; `unplug_force; `pause; `unpause] + +let all_on_boot = [`reset; `persist] + +let all_vdi_type = + [ + `system + ; `user + ; `ephemeral + ; `suspend + ; `crashdump + ; `ha_statefile + ; `metadata + ; `redo_log + ; `rrd + ; `pvs_cache + ; `cbt_metadata + ] + +let all_vdi_operations = + [ + `clone + ; `copy + ; `resize + ; `resize_online + ; `snapshot + ; `mirror + ; `destroy + ; `forget + ; `update + ; `force_unlock + ; `generate_config + ; `enable_cbt + ; `disable_cbt + ; `data_destroy + ; `list_changed_blocks + ; `set_on_boot + ; `blocked + ] + +let all_storage_operations = + [ + `scan + ; `destroy + ; `forget + ; `plug + ; `unplug + ; `update + ; `vdi_create + ; `vdi_introduce + ; `vdi_destroy + ; `vdi_resize + ; `vdi_clone + ; `vdi_snapshot + ; `vdi_mirror + ; `vdi_enable_cbt + ; `vdi_disable_cbt + ; `vdi_data_destroy + ; `vdi_list_changed_blocks + ; `vdi_set_on_boot + ; `pbd_create + ; `pbd_destroy + ] + +let all_bond_mode = [`balanceslb; `activebackup; `lacp] + +let all_primary_address_type = [`IPv4; `IPv6] + +let all_ipv6_configuration_mode = [`None; `DHCP; `Static; `Autoconf] + +let all_ip_configuration_mode = [`None; `DHCP; `Static] + +let all_pif_igmp_status = [`enabled; `disabled; `unknown] + +let all_vif_ipv6_configuration_mode = [`None; `Static] + +let all_vif_ipv4_configuration_mode = [`None; `Static] + +let all_vif_locking_mode = [`network_default; `locked; `unlocked; `disabled] + +let all_vif_operations = [`attach; `plug; `unplug] + +let all_network_purpose = [`nbd; `insecure_nbd] + +let all_network_default_locking_mode = [`unlocked; `disabled] + +let all_network_operations = [`attaching] + +let all_host_numa_affinity_policy = [`any; `best_effort; `default_policy] + +let all_host_sched_gran = [`core; `cpu; `socket] + +let all_latest_synced_updates_applied_state = [`yes; `no; `unknown] + +let all_update_guidances = + [ + `reboot_host + ; `reboot_host_on_livepatch_failure + ; `restart_toolstack + ; `restart_device_model + ] + +let all_host_display = + [`enabled; `disable_on_reboot; `disabled; `enable_on_reboot] + +let all_host_allowed_operations = + [ + `provision + ; `evacuate + ; `shutdown + ; `reboot + ; `power_on + ; `vm_start + ; `vm_resume + ; `vm_migrate + ; `apply_updates + ] + +let all_vm_appliance_operation = + [`start; `clean_shutdown; `hard_shutdown; `shutdown] + +let all_vmss_type = [`snapshot; `checkpoint; `snapshot_with_quiesce] + +let all_vmss_frequency = [`hourly; `daily; `weekly] + +let all_vmpp_archive_target_type = [`none; `cifs; `nfs] + +let all_vmpp_archive_frequency = [`never; `always_after_backup; `daily; `weekly] + +let all_vmpp_backup_frequency = [`hourly; `daily; `weekly] + +let all_vmpp_backup_type = [`snapshot; `checkpoint] + +let all_tristate_type = [`yes; `no; `unspecified] + +let all_domain_type = [`hvm; `pv; `pv_in_pvh; `pvh; `unspecified] + +let all_on_crash_behaviour = + [ + `destroy + ; `coredump_and_destroy + ; `restart + ; `coredump_and_restart + ; `preserve + ; `rename_restart + ] + +let all_vm_operations = + [ + `snapshot + ; `clone + ; `copy + ; `create_template + ; `revert + ; `checkpoint + ; `snapshot_with_quiesce + ; `provision + ; `start + ; `start_on + ; `pause + ; `unpause + ; `clean_shutdown + ; `clean_reboot + ; `hard_shutdown + ; `power_state_reset + ; `hard_reboot + ; `suspend + ; `csvm + ; `resume + ; `resume_on + ; `pool_migrate + ; `migrate_send + ; `get_boot_record + ; `send_sysrq + ; `send_trigger + ; `query_services + ; `shutdown + ; `call_plugin + ; `changing_memory_live + ; `awaiting_memory_live + ; `changing_dynamic_range + ; `changing_static_range + ; `changing_memory_limits + ; `changing_shadow_memory + ; `changing_shadow_memory_live + ; `changing_VCPUs + ; `changing_VCPUs_live + ; `changing_NVRAM + ; `assert_operation_valid + ; `data_source_op + ; `update_allowed_operations + ; `make_into_template + ; `import + ; `export + ; `metadata_export + ; `reverting + ; `destroy + ; `create_vtpm + ] + +let all_on_normal_exit = [`destroy; `restart] + +let all_on_softreboot_behavior = [`soft_reboot; `destroy; `restart; `preserve] + +let all_vm_power_state = [`Halted; `Paused; `Running; `Suspended] + +let all_update_after_apply_guidance = + [`restartHVM; `restartPV; `restartHost; `restartXAPI] + +let all_after_apply_guidance = + [`restartHVM; `restartPV; `restartHost; `restartXAPI] + +let all_update_sync_frequency = [`daily; `weekly] + +let all_telemetry_frequency = [`daily; `weekly; `monthly] + +let all_pool_allowed_operations = + [ + `ha_enable + ; `ha_disable + ; `cluster_create + ; `designate_new_master + ; `configure_repositories + ; `sync_updates + ; `get_updates + ; `apply_updates + ; `tls_verification_enable + ; `cert_refresh + ; `exchange_certificates_on_join + ; `exchange_ca_certificates_on_join + ; `copy_primary_host_certs + ] + +let all_task_status_type = + [`pending; `success; `failure; `cancelling; `cancelled] + +let all_task_allowed_operations = [`cancel; `destroy] + +let all_hello_return = [`ok; `unknown_host; `cannot_talk_back] + +let all_livepatch_status = + [`ok_livepatch_complete; `ok_livepatch_incomplete; `ok] + +let all_sr_health = [`healthy; `recovering] + +let all_event_operation = [`add; `del; `_mod] diff --git a/ocaml/tests/record_util/old_record_util.ml b/ocaml/tests/record_util/old_record_util.ml new file mode 100644 index 00000000000..ad38fe7ea37 --- /dev/null +++ b/ocaml/tests/record_util/old_record_util.ml @@ -0,0 +1,1182 @@ +(* + * 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. + *) +(* conversion utils *) + +exception Record_failure of string + +let to_str = function Rpc.String x -> x | _ -> failwith "Invalid" + +let certificate_type_to_string = function + | `host -> + "host" + | `host_internal -> + "host_internal" + | `ca -> + "ca" + +let class_to_string cls = + match cls with + | `VM -> + "VM" + | `Host -> + "Host" + | `SR -> + "SR" + | `Pool -> + "Pool" + | `VMPP -> + "VMPP" + | `VMSS -> + "VMSS" + | `PVS_proxy -> + "PVS_proxy" + | `VDI -> + "VDI" + | `Certificate -> + "Certificate" + | _ -> + "unknown" + +let string_to_class str = + match str with + | "VM" -> + `VM + | "Host" -> + `Host + | "SR" -> + `SR + | "Pool" -> + `Pool + | "VMPP" -> + `VMPP + | "VMSS" -> + `VMSS + | "PVS_proxy" -> + `PVS_proxy + | "VDI" -> + `VDI + | "Certificate" -> + `Certificate + | _ -> + failwith "Bad type" + +let power_state_to_string state = + match state with + | `Halted -> + "Halted" + | `Paused -> + "Paused" + | `Running -> + "Running" + | `Suspended -> + "Suspended" + | `ShuttingDown -> + "Shutting down" + | `Migrating -> + "Migrating" + +let vm_operation_table = + [ + (`assert_operation_valid, "assertoperationvalid") + ; (`changing_dynamic_range, "changing_dynamic_range") + ; (`changing_static_range, "changing_static_range") + ; (`changing_shadow_memory, "changing_shadow_memory") + ; (`clean_reboot, "clean_reboot") + ; (`clean_shutdown, "clean_shutdown") + ; (`clone, "clone") + ; (`snapshot, "snapshot") + ; (`checkpoint, "checkpoint") + ; (`snapshot_with_quiesce, "snapshot_with_quiesce") + ; (`copy, "copy") + ; (`revert, "revert") + ; (`reverting, "reverting") + ; (`provision, "provision") + ; (`destroy, "destroy") + ; (`export, "export") + ; (`metadata_export, "metadata_export") + ; (`import, "import") + ; (`get_boot_record, "get_boot_record") + ; (`data_source_op, "data_sources_op") + ; (`hard_reboot, "hard_reboot") + ; (`hard_shutdown, "hard_shutdown") + ; (`migrate_send, "migrate_send") + ; (`pause, "pause") + ; (`resume, "resume") + ; (`resume_on, "resume_on") + ; (`changing_VCPUs_live, "changing_VCPUs_live") + ; (`changing_NVRAM, "changing_NVRAM") + ; (`start, "start") + ; (`start_on, "start_on") + ; (`shutdown, "shutdown") + ; (`suspend, "suspend") + ; (`unpause, "unpause") + ; (`update_allowed_operations, "update_allowed_operations") + ; (`make_into_template, "make_into_template") + ; (`send_sysrq, "send_sysrq") + ; (`send_trigger, "send_trigger") + ; (`changing_memory_live, "changing_memory_live") + ; (`awaiting_memory_live, "awaiting_memory_live") + ; (`changing_shadow_memory_live, "changing_shadow_memory_live") + ; (`pool_migrate, "pool_migrate") + ; (`power_state_reset, "power_state_reset") + ; (`csvm, "csvm") + ; (`call_plugin, "call_plugin") + ; (`create_vtpm, "create_vtpm") + ] + +let vm_operation_to_string x = + if not (List.mem_assoc x vm_operation_table) then + "(unknown operation)" + else + List.assoc x vm_operation_table + +let string_to_vm_operation x = + let table = List.map (fun (a, b) -> (b, a)) vm_operation_table in + if not (List.mem_assoc x table) then + raise + (Api_errors.Server_error + (Api_errors.invalid_value, ["blocked_operation"; x]) + ) + else + List.assoc x table + +let pool_operation_to_string = function + | `ha_enable -> + "ha_enable" + | `ha_disable -> + "ha_disable" + | `cluster_create -> + "cluster_create" + | `designate_new_master -> + "designate_new_master" + | `tls_verification_enable -> + "tls_verification_enable" + | `configure_repositories -> + "configure_repositories" + | `sync_updates -> + "sync_updates" + | `get_updates -> + "get_updates" + | `apply_updates -> + "apply_updates" + | `cert_refresh -> + "cert_refresh" + | `exchange_certificates_on_join -> + "exchange_certificates_on_join" + | `exchange_ca_certificates_on_join -> + "exchange_ca_certificates_on_join" + | `copy_primary_host_certs -> + "copy_primary_host_certs" + +let host_operation_to_string = function + | `provision -> + "provision" + | `evacuate -> + "evacuate" + | `shutdown -> + "shutdown" + | `reboot -> + "reboot" + | `power_on -> + "power_on" + | `vm_start -> + "VM.start" + | `vm_resume -> + "VM.resume" + | `vm_migrate -> + "VM.migrate" + | `apply_updates -> + "apply_updates" + +let update_guidance_to_string = function + | `reboot_host -> + "reboot_host" + | `reboot_host_on_livepatch_failure -> + "reboot_host_on_livepatch_failure" + | `restart_toolstack -> + "restart_toolstack" + | `restart_device_model -> + "restart_device_model" + +let latest_synced_updates_applied_state_to_string = function + | `yes -> + "yes" + | `no -> + "no" + | `unknown -> + "unknown" + +let vdi_operation_to_string : API.vdi_operations -> string = function + | `clone -> + "clone" + | `copy -> + "copy" + | `resize -> + "resize" + | `resize_online -> + "resize_online" + | `destroy -> + "destroy" + | `force_unlock -> + "force_unlock" + | `snapshot -> + "snapshot" + | `mirror -> + "mirror" + | `forget -> + "forget" + | `update -> + "update" + | `generate_config -> + "generate_config" + | `enable_cbt -> + "enable_cbt" + | `disable_cbt -> + "disable_cbt" + | `data_destroy -> + "data_destroy" + | `list_changed_blocks -> + "list_changed_blocks" + | `set_on_boot -> + "set_on_boot" + | `blocked -> + "blocked" + +let sr_operation_to_string : API.storage_operations -> string = function + | `scan -> + "scan" + | `destroy -> + "destroy" + | `forget -> + "forget" + | `plug -> + "plug" + | `unplug -> + "unplug" + | `update -> + "update" + | `vdi_create -> + "VDI.create" + | `vdi_introduce -> + "VDI.introduce" + | `vdi_destroy -> + "VDI.destroy" + | `vdi_resize -> + "VDI.resize" + | `vdi_clone -> + "VDI.clone" + | `vdi_snapshot -> + "VDI.snapshot" + | `vdi_mirror -> + "VDI.mirror" + | `vdi_enable_cbt -> + "VDI.enable_cbt" + | `vdi_disable_cbt -> + "VDI.disable_cbt" + | `vdi_set_on_boot -> + "VDI.set_on_boot" + | `vdi_data_destroy -> + "VDI.data_destroy" + | `vdi_list_changed_blocks -> + "VDI.list_changed_blocks" + | `pbd_create -> + "PBD.create" + | `pbd_destroy -> + "PBD.destroy" + +let vbd_operation_to_string = function + | `attach -> + "attach" + | `eject -> + "eject" + | `insert -> + "insert" + | `plug -> + "plug" + | `unplug -> + "unplug" + | `unplug_force -> + "unplug_force" + | `pause -> + "pause" + | `unpause -> + "unpause" + +let vif_operation_to_string = function + | `attach -> + "attach" + | `plug -> + "plug" + | `unplug -> + "unplug" + | `unplug_force -> + "unplug_force" + +let vif_locking_mode_to_string = function + | `network_default -> + "network_default" + | `locked -> + "locked" + | `unlocked -> + "unlocked" + | `disabled -> + "disabled" + +let string_to_vif_locking_mode = function + | "network_default" -> + `network_default + | "locked" -> + `locked + | "unlocked" -> + `unlocked + | "disabled" -> + `disabled + | s -> + raise + (Record_failure + ("Expected 'network_default', 'locked', 'unlocked', 'disabled', got " + ^ s + ) + ) + +let vmss_type_to_string = function + | `snapshot -> + "snapshot" + | `checkpoint -> + "checkpoint" + | `snapshot_with_quiesce -> + "snapshot_with_quiesce" + +let string_to_vmss_type = function + | "snapshot" -> + `snapshot + | "checkpoint" -> + `checkpoint + | "snapshot_with_quiesce" -> + `snapshot_with_quiesce + | s -> + raise + (Record_failure + ("Expected 'snapshot', 'checkpoint', 'snapshot_with_quiesce', got " + ^ s + ) + ) + +let vmss_frequency_to_string = function + | `hourly -> + "hourly" + | `daily -> + "daily" + | `weekly -> + "weekly" + +let string_to_vmss_frequency = function + | "hourly" -> + `hourly + | "daily" -> + `daily + | "weekly" -> + `weekly + | s -> + raise (Record_failure ("Expected 'hourly', 'daily', 'weekly', got " ^ s)) + +let network_default_locking_mode_to_string = function + | `unlocked -> + "unlocked" + | `disabled -> + "disabled" + +let string_to_network_default_locking_mode = function + | "unlocked" -> + `unlocked + | "disabled" -> + `disabled + | s -> + raise (Record_failure ("Expected 'unlocked' or 'disabled', got " ^ s)) + +let network_purpose_to_string : API.network_purpose -> string = function + | `nbd -> + "nbd" + | `insecure_nbd -> + "insecure_nbd" + +let string_to_network_purpose : string -> API.network_purpose = function + | "nbd" -> + `nbd + | "insecure_nbd" -> + `insecure_nbd + | s -> + raise (Record_failure ("Expected a network purpose string; got " ^ s)) + +let vm_appliance_operation_to_string = function + | `start -> + "start" + | `clean_shutdown -> + "clean_shutdown" + | `hard_shutdown -> + "hard_shutdown" + | `shutdown -> + "shutdown" + +let cpu_feature_to_string f = + match f with + | `FPU -> + "FPU" + | `VME -> + "VME" + | `DE -> + "DE" + | `PSE -> + "PSE" + | `TSC -> + "TSC" + | `MSR -> + "MSR" + | `PAE -> + "PAE" + | `MCE -> + "MCE" + | `CX8 -> + "CX8" + | `APIC -> + "APIC" + | `SEP -> + "SEP" + | `MTRR -> + "MTRR" + | `PGE -> + "PGE" + | `MCA -> + "MCA" + | `CMOV -> + "CMOV" + | `PAT -> + "PAT" + | `PSE36 -> + "PSE36" + | `PN -> + "PN" + | `CLFLSH -> + "CLFLSH" + | `DTES -> + "DTES" + | `ACPI -> + "ACPI" + | `MMX -> + "MMX" + | `FXSR -> + "FXSR" + | `XMM -> + "XMM" + | `XMM2 -> + "XMM2" + | `SELFSNOOP -> + "SELFSNOOP" + | `HT -> + "HT" + | `ACC -> + "ACC" + | `IA64 -> + "IA64" + | `SYSCALL -> + "SYSCALL" + | `MP -> + "MP" + | `NX -> + "NX" + | `MMXEXT -> + "MMXEXT" + | `LM -> + "LM" + | `THREEDNOWEXT -> + "3DNOWEXT" + | `THREEDNOW -> + "3DNOW" + | `RECOVERY -> + "RECOVERY" + | `LONGRUN -> + "LONGRUN" + | `LRTI -> + "LRTI" + | `CXMMX -> + "CXMMX" + | `K6MTRR -> + "K6MTRR" + | `CYRIXARR -> + "CYRIXARR" + | `CENTAURMCR -> + "CENTAURMCR" + | `K8 -> + "K8" + | `K7 -> + "K7" + | `P3 -> + "P3" + | `P4 -> + "P4" + | `CONSTANTTSC -> + "CONSTANTTSC" + | `FXSAVELEAK -> + "FXSAVELEAK" + | `XMM3 -> + "XMM3" + | `MWAIT -> + "MWAIT" + | `DSCPL -> + "DSCPL" + | `EST -> + "EST" + | `TM2 -> + "TM2" + | `CID -> + "CID" + | `CX16 -> + "CX16" + | `XTPR -> + "XTPR" + | `XSTORE -> + "XSTORE" + | `XSTOREEN -> + "XSTOREEN" + | `XCRYPT -> + "XCRYPT" + | `XCRYPTEN -> + "XCRYPTEN" + | `LAHFLM -> + "LAHFLM" + | `CMPLEGACY -> + "CMPLEGACY" + | `VMX -> + "VMX" + +let task_status_type_to_string s = + match s with + | `pending -> + "pending" + | `success -> + "success" + | `failure -> + "failure" + | `cancelling -> + "cancelling" + | `cancelled -> + "cancelled" + +let protocol_to_string = function + | `vt100 -> + "VT100" + | `rfb -> + "RFB" + | `rdp -> + "RDP" + +let telemetry_frequency_to_string = function + | `daily -> + "daily" + | `weekly -> + "weekly" + | `monthly -> + "monthly" + +let task_allowed_operations_to_string s = + match s with `cancel -> "Cancel" | `destroy -> "Destroy" + +let alert_level_to_string s = + match s with `Info -> "info" | `Warn -> "warning" | `Error -> "error" + +let on_normal_exit_to_string x = + match x with `destroy -> "Destroy" | `restart -> "Restart" + +let string_to_on_normal_exit s = + match String.lowercase_ascii s with + | "destroy" -> + `destroy + | "restart" -> + `restart + | _ -> + raise (Record_failure ("Expected 'destroy' or 'restart', got " ^ s)) + +let on_crash_behaviour_to_string x = + match x with + | `destroy -> + "Destroy" + | `coredump_and_destroy -> + "Core dump and destroy" + | `restart -> + "Restart" + | `coredump_and_restart -> + "Core dump and restart" + | `preserve -> + "Preserve" + | `rename_restart -> + "Rename restart" + +let string_to_on_crash_behaviour s = + match String.lowercase_ascii s with + | "destroy" -> + `destroy + | "coredump_and_destroy" -> + `coredump_and_destroy + | "restart" -> + `restart + | "coredump_and_restart" -> + `coredump_and_restart + | "preserve" -> + `preserve + | "rename_restart" -> + `rename_restart + | _ -> + raise + (Record_failure + ("Expected 'destroy', 'coredump_and_destroy'," + ^ "'restart', 'coredump_and_restart', 'preserve' or \ + 'rename_restart', got " + ^ s + ) + ) + +let on_softreboot_behaviour_to_string x = + match x with + | `destroy -> + "Destroy" + | `restart -> + "Restart" + | `preserve -> + "Preserve" + | `soft_reboot -> + "Soft reboot" + +let string_to_on_softreboot_behaviour s = + match String.lowercase_ascii s with + | "destroy" -> + `destroy + | "restart" -> + `restart + | "preserve" -> + `preserve + | "soft_reboot" -> + `soft_reboot + | _ -> + raise + (Record_failure + ("Expected 'destroy', 'coredump_and_destroy'," + ^ "'restart', 'coredump_and_restart', 'preserve', 'soft_reboot' or \ + 'rename_restart', got " + ^ s + ) + ) + +let host_display_to_string h = + match h with + | `enabled -> + "enabled" + | `enable_on_reboot -> + "enable_on_reboot" + | `disabled -> + "disabled" + | `disable_on_reboot -> + "disable_on_reboot" + +let host_sched_gran_of_string s = + match String.lowercase_ascii s with + | "core" -> + `core + | "cpu" -> + `cpu + | "socket" -> + `socket + | _ -> + raise (Record_failure ("Expected 'core','cpu', 'socket', got " ^ s)) + +let host_sched_gran_to_string = function + | `core -> + "core" + | `cpu -> + "cpu" + | `socket -> + "socket" + +let host_numa_affinity_policy_to_string = function + | `any -> + "any" + | `best_effort -> + "best_effort" + | `default_policy -> + "default_policy" + +let host_numa_affinity_policy_of_string a = + match String.lowercase_ascii a with + | "any" -> + `any + | "best_effort" -> + `best_effort + | "default_policy" -> + `default_policy + | s -> + raise + (Record_failure + ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) + ) + +let pci_dom0_access_to_string x = host_display_to_string x + +let string_to_vdi_onboot s = + match String.lowercase_ascii s with + | "persist" -> + `persist + | "reset" -> + `reset + | _ -> + raise (Record_failure ("Expected 'persist' or 'reset', got " ^ s)) + +let string_to_vbd_mode s = + match String.lowercase_ascii s with + | "ro" -> + `RO + | "rw" -> + `RW + | _ -> + raise (Record_failure ("Expected 'RO' or 'RW', got " ^ s)) + +let vbd_mode_to_string = function `RO -> "ro" | `RW -> "rw" + +let string_to_vbd_type s = + match String.lowercase_ascii s with + | "cd" -> + `CD + | "disk" -> + `Disk + | "floppy" -> + `Floppy + | _ -> + raise (Record_failure ("Expected 'CD' or 'Disk', got " ^ s)) + +let power_to_string h = + match h with + | `Halted -> + "halted" + | `Paused -> + "paused" + | `Running -> + "running" + | `Suspended -> + "suspended" + | `ShuttingDown -> + "shutting down" + | `Migrating -> + "migrating" + +let vdi_type_to_string t = + match t with + | `system -> + "System" + | `user -> + "User" + | `ephemeral -> + "Ephemeral" + | `suspend -> + "Suspend" + | `crashdump -> + "Crashdump" + | `ha_statefile -> + "HA statefile" + | `metadata -> + "Metadata" + | `redo_log -> + "Redo log" + | `rrd -> + "rrd" + | `pvs_cache -> + "PVS cache" + | `cbt_metadata -> + "CBT metadata" + +let ip_configuration_mode_to_string = function + | `None -> + "None" + | `DHCP -> + "DHCP" + | `Static -> + "Static" + +let ip_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "dhcp" -> + `DHCP + | "none" -> + `None + | "static" -> + `Static + | s -> + raise (Record_failure ("Expected 'dhcp','none' or 'static', got " ^ s)) + +let vif_ipv4_configuration_mode_to_string = function + | `None -> + "None" + | `Static -> + "Static" + +let vif_ipv4_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "none" -> + `None + | "static" -> + `Static + | s -> + raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + +let ipv6_configuration_mode_to_string = function + | `None -> + "None" + | `DHCP -> + "DHCP" + | `Static -> + "Static" + | `Autoconf -> + "Autoconf" + +let ipv6_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "dhcp" -> + `DHCP + | "none" -> + `None + | "static" -> + `Static + | "autoconf" -> + `Autoconf + | s -> + raise + (Record_failure + ("Expected 'dhcp','none' 'autoconf' or 'static', got " ^ s) + ) + +let vif_ipv6_configuration_mode_to_string = function + | `None -> + "None" + | `Static -> + "Static" + +let vif_ipv6_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "none" -> + `None + | "static" -> + `Static + | s -> + raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + +let primary_address_type_to_string = function + | `IPv4 -> + "IPv4" + | `IPv6 -> + "IPv6" + +let primary_address_type_of_string m = + match String.lowercase_ascii m with + | "ipv4" -> + `IPv4 + | "ipv6" -> + `IPv6 + | s -> + raise (Record_failure ("Expected 'ipv4' or 'ipv6', got " ^ s)) + +let bond_mode_to_string = function + | `balanceslb -> + "balance-slb" + | `activebackup -> + "active-backup" + | `lacp -> + "lacp" + +let bond_mode_of_string m = + match String.lowercase_ascii m with + | "balance-slb" | "" -> + `balanceslb + | "active-backup" -> + `activebackup + | "lacp" -> + `lacp + | s -> + raise (Record_failure ("Invalid bond mode. Got " ^ s)) + +let allocation_algorithm_to_string = function + | `depth_first -> + "depth-first" + | `breadth_first -> + "breadth-first" + +let allocation_algorithm_of_string a = + match String.lowercase_ascii a with + | "depth-first" -> + `depth_first + | "breadth-first" -> + `breadth_first + | s -> + raise (Record_failure ("Invalid allocation algorithm. Got " ^ s)) + +let pvs_proxy_status_to_string = function + | `stopped -> + "stopped" + | `initialised -> + "initialised" + | `caching -> + "caching" + | `incompatible_write_cache_mode -> + "incompatible-write-cache-mode" + | `incompatible_protocol_version -> + "incompatible-protocol-version" + +let cluster_operation_to_string op = API.rpc_of_cluster_operation op |> to_str + +let cluster_host_operation_to_string op = + API.rpc_of_cluster_host_operation op |> to_str + +let bool_of_string s = + match String.lowercase_ascii s with + | "true" | "yes" -> + true + | "false" | "no" -> + false + | _ -> + raise (Record_failure ("Expected 'true','yes','false','no', got " ^ s)) + +let sdn_protocol_of_string s = + match String.lowercase_ascii s with + | "ssl" -> + `ssl + | "pssl" -> + `pssl + | _ -> + raise (Record_failure ("Expected 'ssl','pssl', got " ^ s)) + +let sdn_protocol_to_string = function `ssl -> "ssl" | `pssl -> "pssl" + +let tunnel_protocol_of_string s = + match String.lowercase_ascii s with + | "gre" -> + `gre + | "vxlan" -> + `vxlan + | _ -> + raise (Record_failure ("Expected 'gre','vxlan', got " ^ s)) + +let tunnel_protocol_to_string = function `gre -> "gre" | `vxlan -> "vxlan" + +let pif_igmp_status_to_string = function + | `enabled -> + "enabled" + | `disabled -> + "disabled" + | `unknown -> + "unknown" + +let vusb_operation_to_string = function + | `attach -> + "attach" + | `plug -> + "plug" + | `unplug -> + "unplug" + +let network_sriov_configuration_mode_to_string = function + | `sysfs -> + "sysfs" + | `modprobe -> + "modprobe" + | `manual -> + "manual" + | `unknown -> + "unknown" + +(* string_to_string_map_to_string *) +let s2sm_to_string sep x = + String.concat sep (List.map (fun (a, b) -> a ^ ": " ^ b) x) + +(* string to blob ref map to string *) +let s2brm_to_string get_uuid_from_ref sep x = + String.concat sep (List.map (fun (n, r) -> n ^ ": " ^ get_uuid_from_ref r) x) + +let on_boot_to_string onboot = + match onboot with `reset -> "reset" | `persist -> "persist" + +let tristate_to_string tristate = + match tristate with + | `yes -> + "true" + | `no -> + "false" + | `unspecified -> + "unspecified" + +let domain_type_to_string = function + | `hvm -> + "hvm" + | `pv -> + "pv" + | `pv_in_pvh -> + "pv-in-pvh" + | `pvh -> + "pvh" + | `unspecified -> + "unspecified" + +let domain_type_of_string x = + match String.lowercase_ascii x with + | "hvm" -> + `hvm + | "pv" -> + `pv + | "pv-in-pvh" -> + `pv_in_pvh + | "pvh" -> + `pvh + | s -> + raise (Record_failure ("Invalid domain type. Got " ^ s)) + +let vtpm_operation_to_string (op : API.vtpm_operations) = + match op with `destroy -> "destroy" + +(** Parse a string which might have a units suffix on the end *) +let bytes_of_string field x = + let ( ** ) a b = Int64.mul a b in + let max_size_TiB = + Int64.div Int64.max_int (1024L ** 1024L ** 1024L ** 1024L) + in + (* detect big number that cannot be represented by Int64. *) + let int64_of_string s = + try Int64.of_string s + with _ -> + if s = "" then + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer (possibly \ + with suffix)" + field + ) + ) ; + let alldigit = ref true and i = ref (String.length s - 1) in + while !alldigit && !i > 0 do + alldigit := Astring.Char.Ascii.is_digit s.[!i] ; + decr i + done ; + if !alldigit then + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': number too big (maximum = %Ld TiB)" + field max_size_TiB + ) + ) + else + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer (possibly \ + with suffix)" + field + ) + ) + in + match + Astring.( + String.fields ~empty:false ~is_sep:(fun c -> + Char.Ascii.(is_white c || is_digit c) + ) + ) + x + with + | [] -> + (* no suffix on the end *) + int64_of_string x + | [suffix] -> + let number = + match + Astring.( + String.fields ~empty:false ~is_sep:(Fun.negate Char.Ascii.is_digit) + ) + x + with + | [number] -> + int64_of_string number + | _ -> + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer \ + (possibly with suffix)" + field + ) + ) + in + let multiplier = + match suffix with + | "bytes" -> + 1L + | "KiB" -> + 1024L + | "MiB" -> + 1024L ** 1024L + | "GiB" -> + 1024L ** 1024L ** 1024L + | "TiB" -> + 1024L ** 1024L ** 1024L ** 1024L + | x -> + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': Unknown suffix: '%s' (try \ + KiB, MiB, GiB or TiB)" + field x + ) + ) + in + (* FIXME: detect overflow *) + number ** multiplier + | _ -> + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer (possibly with \ + suffix)" + field + ) + ) + +(* Vincent's random mac utils *) + +let mac_from_int_array macs = + (* make sure bit 1 (local) is set and bit 0 (unicast) is clear *) + macs.(0) <- macs.(0) lor 0x2 land lnot 0x1 ; + Printf.sprintf "%02x:%02x:%02x:%02x:%02x:%02x" macs.(0) macs.(1) macs.(2) + macs.(3) macs.(4) macs.(5) + +(* generate a random mac that is locally administered *) +let random_mac_local () = mac_from_int_array (Array.make 6 (Random.int 0x100)) + +let update_sync_frequency_to_string = function + | `daily -> + "daily" + | `weekly -> + "weekly" + +let update_sync_frequency_of_string s = + match String.lowercase_ascii s with + | "daily" -> + `daily + | "weekly" -> + `weekly + | _ -> + raise (Record_failure ("Expected 'daily', 'weekly', got " ^ s)) diff --git a/ocaml/tests/record_util/test_record_util.ml b/ocaml/tests/record_util/test_record_util.ml new file mode 100644 index 00000000000..3ed5c2d7351 --- /dev/null +++ b/ocaml/tests/record_util/test_record_util.ml @@ -0,0 +1,251 @@ +module O = Old_record_util +module N = Record_util +open Old_enum_all +open Printf +open Alcotest + +let test_to_string ~name all_enum (old_to_string, new_to_string) = + ( name ^ "to_string" + , all_enum + |> List.map @@ fun enum -> + let expected = old_to_string enum in + V1.test_case expected `Quick @@ fun () -> + let actual = new_to_string enum in + V1.(check' ~msg:"compatible" ~expected ~actual string) + ) + +(* If record_util raises on of_string of a valid enum, it should raise the same exception. + Currently this only happens on 'unspecified' VM domain type. +*) +let wrap f x = try Ok (f x) with e -> Error e + +let drop_module_prefix s = + match Astring.String.cut ~sep:"." s with + | Some (_module, rest) -> + rest + | None -> + s + +let drop_exn_arguments s = + match Astring.String.cut ~sep:"(" s with + | Some (typ, _args) -> + typ + | None -> + s + +let exn_to_string_strip e = + (* Drop the module prefix: that is expected to be different. + We'll only look at the exception type and not its string arguments, + to allow improving the error message in the future. + *) + e |> Printexc.to_string |> drop_module_prefix |> drop_exn_arguments + +let exn_equal_strip a b = + String.equal (exn_to_string_strip a) (exn_to_string_strip b) + +let exn = V1.testable (Fmt.of_to_string exn_to_string_strip) exn_equal_strip + +let test_of_string ~name all_enum old_to_string of_string_opt = + of_string_opt + |> Option.map (fun (old_of_string, new_of_string) -> + let make input = + V1.test_case input `Quick @@ fun () -> + let expected = wrap old_of_string input in + let actual = wrap new_of_string input in + let pp_enum = Fmt.of_to_string old_to_string in + V1.( + check' ~msg:"compatible" ~expected ~actual + @@ result (testable pp_enum ( = )) exn + ) + in + ( name ^ "of_string" + , make "bad-BaD-BAD" + :: (all_enum + |> List.concat_map @@ fun enum -> + let input = old_to_string enum in + [ + make input + ; make (String.capitalize_ascii input) + ; make (String.uppercase_ascii input) + ] + ) + ) + ) + |> Option.to_list + +let mk line of_string_opt all_enum (old_to_string, new_to_string) = + let name = sprintf "line%d:" line in + test_to_string ~name all_enum (old_to_string, new_to_string) + :: test_of_string ~name all_enum old_to_string of_string_opt + +(* +Created by: +``` +grep 'let.*to_string' old_record_util.ml | sed -re 's/^let ([^ ]+)_to_string.*/\1/' | while read ENUM; do if grep "${ENUM}_of_string" old_record_util.ml >/dev/null; then echo "; mk __LINE__ (Some (O.${ENUM}_of_string, N.${ENUM}_of_string)) all_${ENUM} (O.${ENUM}_to_string, N.${ENUM}_to_string)"; else echo "; mk __LINE__ None all_${ENUM} (O.${ENUM}_to_string, N.${ENUM}_to_string)"; fi; done +``` +and then tweaked to compile using LSP hints where the names were not consistent (e.g. singular vs plural, etc.) +*) +let tests = + [ + mk __LINE__ None all_certificate_type + (O.certificate_type_to_string, N.certificate_type_to_string) + ; mk __LINE__ None all_cls (O.class_to_string, N.class_to_string) + ; mk __LINE__ None all_vm_power_state + (O.power_state_to_string, N.power_state_to_string) + ; mk __LINE__ None all_vm_operations + (O.vm_operation_to_string, N.vm_operation_to_string) + ; mk __LINE__ None all_pool_allowed_operations + (O.pool_operation_to_string, N.pool_operation_to_string) + ; mk __LINE__ None all_host_allowed_operations + (O.host_operation_to_string, N.host_operation_to_string) + ; mk __LINE__ None all_update_guidances + (O.update_guidance_to_string, N.update_guidance_to_string) + ; mk __LINE__ None all_latest_synced_updates_applied_state + ( O.latest_synced_updates_applied_state_to_string + , N.latest_synced_updates_applied_state_to_string + ) + ; mk __LINE__ None all_vdi_operations + (O.vdi_operation_to_string, N.vdi_operation_to_string) + ; mk __LINE__ None all_storage_operations + (O.sr_operation_to_string, N.sr_operation_to_string) + ; mk __LINE__ None all_vbd_operations + (O.vbd_operation_to_string, N.vbd_operation_to_string) + ; mk __LINE__ None all_vif_operations + (O.vif_operation_to_string, N.vif_operation_to_string) + ; mk __LINE__ None all_vif_locking_mode + (O.vif_locking_mode_to_string, N.vif_locking_mode_to_string) + ; mk __LINE__ None all_vmss_type (O.vmss_type_to_string, N.vmss_type_to_string) + ; mk __LINE__ None all_vmss_frequency + (O.vmss_frequency_to_string, N.vmss_frequency_to_string) + ; mk __LINE__ None all_network_default_locking_mode + ( O.network_default_locking_mode_to_string + , N.network_default_locking_mode_to_string + ) + ; mk __LINE__ None all_network_purpose + (O.network_purpose_to_string, N.network_purpose_to_string) + ; mk __LINE__ None all_vm_appliance_operation + (O.vm_appliance_operation_to_string, N.vm_appliance_operation_to_string) + (*; mk __LINE__ None all_cpu_feature (O.cpu_feature_to_string, N.cpu_feature_to_string)*) + ; mk __LINE__ None all_task_status_type + (O.task_status_type_to_string, N.task_status_type_to_string) + ; mk __LINE__ None all_console_protocol + (O.protocol_to_string, N.protocol_to_string) + ; mk __LINE__ None all_telemetry_frequency + (O.telemetry_frequency_to_string, N.telemetry_frequency_to_string) + ; mk __LINE__ None all_task_allowed_operations + (O.task_allowed_operations_to_string, N.task_allowed_operations_to_string) + (*; mk __LINE__ None all_alert_level (O.alert_level_to_string, N.alert_level_to_string)*) + ; mk __LINE__ None all_on_normal_exit + (O.on_normal_exit_to_string, N.on_normal_exit_to_string) + ; mk __LINE__ None all_on_crash_behaviour + (O.on_crash_behaviour_to_string, N.on_crash_behaviour_to_string) + ; mk __LINE__ None all_on_softreboot_behavior + (O.on_softreboot_behaviour_to_string, N.on_softreboot_behaviour_to_string) + ; mk __LINE__ None all_host_display + (O.host_display_to_string, N.host_display_to_string) + ; mk __LINE__ + (Some (O.host_sched_gran_of_string, N.host_sched_gran_of_string)) + all_host_sched_gran + (O.host_sched_gran_to_string, N.host_sched_gran_to_string) + ; mk __LINE__ + (Some + ( O.host_numa_affinity_policy_of_string + , N.host_numa_affinity_policy_of_string + ) + ) + all_host_numa_affinity_policy + ( O.host_numa_affinity_policy_to_string + , N.host_numa_affinity_policy_to_string + ) + ; mk __LINE__ None all_pgpu_dom0_access + (O.pci_dom0_access_to_string, N.pci_dom0_access_to_string) + ; mk __LINE__ None all_vbd_mode (O.vbd_mode_to_string, N.vbd_mode_to_string) + (*; mk __LINE__ None all_power (O.power_to_string, N.power_to_string)*) + ; mk __LINE__ None all_vdi_type (O.vdi_type_to_string, N.vdi_type_to_string) + ; mk __LINE__ + (Some + (O.ip_configuration_mode_of_string, N.ip_configuration_mode_of_string) + ) + all_ip_configuration_mode + (O.ip_configuration_mode_to_string, N.ip_configuration_mode_to_string) + ; mk __LINE__ + (Some + ( O.vif_ipv4_configuration_mode_of_string + , N.vif_ipv4_configuration_mode_of_string + ) + ) + all_vif_ipv4_configuration_mode + ( O.vif_ipv4_configuration_mode_to_string + , N.vif_ipv4_configuration_mode_to_string + ) + ; mk __LINE__ + (Some + ( O.ipv6_configuration_mode_of_string + , N.ipv6_configuration_mode_of_string + ) + ) + all_ipv6_configuration_mode + (O.ipv6_configuration_mode_to_string, N.ipv6_configuration_mode_to_string) + ; mk __LINE__ + (Some + ( O.vif_ipv6_configuration_mode_of_string + , N.vif_ipv6_configuration_mode_of_string + ) + ) + all_vif_ipv6_configuration_mode + ( O.vif_ipv6_configuration_mode_to_string + , N.vif_ipv6_configuration_mode_to_string + ) + ; mk __LINE__ + (Some (O.primary_address_type_of_string, N.primary_address_type_of_string)) + all_primary_address_type + (O.primary_address_type_to_string, N.primary_address_type_to_string) + ; mk __LINE__ + (Some (O.bond_mode_of_string, N.bond_mode_of_string)) + all_bond_mode + (O.bond_mode_to_string, N.bond_mode_to_string) + ; mk __LINE__ + (Some (O.allocation_algorithm_of_string, N.allocation_algorithm_of_string)) + all_allocation_algorithm + (O.allocation_algorithm_to_string, N.allocation_algorithm_to_string) + ; mk __LINE__ None all_pvs_proxy_status + (O.pvs_proxy_status_to_string, N.pvs_proxy_status_to_string) + ; mk __LINE__ None all_cluster_operation + (O.cluster_operation_to_string, N.cluster_operation_to_string) + ; mk __LINE__ None all_cluster_host_operation + (O.cluster_host_operation_to_string, N.cluster_host_operation_to_string) + ; mk __LINE__ + (Some (O.sdn_protocol_of_string, N.sdn_protocol_of_string)) + all_sdn_controller_protocol + (O.sdn_protocol_to_string, N.sdn_protocol_to_string) + ; mk __LINE__ + (Some (O.tunnel_protocol_of_string, N.tunnel_protocol_of_string)) + all_tunnel_protocol + (O.tunnel_protocol_to_string, N.tunnel_protocol_to_string) + ; mk __LINE__ None all_pif_igmp_status + (O.pif_igmp_status_to_string, N.pif_igmp_status_to_string) + ; mk __LINE__ None all_vusb_operations + (O.vusb_operation_to_string, N.vusb_operation_to_string) + ; mk __LINE__ None all_sriov_configuration_mode + ( O.network_sriov_configuration_mode_to_string + , N.network_sriov_configuration_mode_to_string + ) + ; mk __LINE__ None all_on_boot (O.on_boot_to_string, N.on_boot_to_string) + ; mk __LINE__ None all_tristate_type + (O.tristate_to_string, N.tristate_to_string) + ; mk __LINE__ + (Some (O.domain_type_of_string, N.domain_type_of_string)) + all_domain_type + (O.domain_type_to_string, N.domain_type_to_string) + ; mk __LINE__ None all_vtpm_operations + (O.vtpm_operation_to_string, N.vtpm_operation_to_string) + ; mk __LINE__ + (Some + (O.update_sync_frequency_of_string, N.update_sync_frequency_of_string) + ) + all_update_sync_frequency + (O.update_sync_frequency_to_string, N.update_sync_frequency_to_string) + ] + |> List.concat + +let () = V1.run "record_util" tests diff --git a/ocaml/tests/test_cluster.ml b/ocaml/tests/test_cluster.ml index d34258c512c..b42621a300f 100644 --- a/ocaml/tests/test_cluster.ml +++ b/ocaml/tests/test_cluster.ml @@ -95,6 +95,10 @@ let test_rpc ~__context call = Rpc.{success= true; contents= Rpc.String ""; is_notification= false} | "Cluster_host.get_cluster_config", _ -> Rpc.{success= true; contents= Rpc.String ""; is_notification= false} + | "Cluster.cstack_sync", [_session; self] -> + let open API in + Xapi_cluster.cstack_sync ~__context ~self:(ref_Cluster_of_rpc self) ; + Rpc.{success= true; contents= Rpc.String ""; is_notification= false} | name, params -> Alcotest.failf "Unexpected RPC: %s(%s)" name (String.concat " " (List.map Rpc.to_string params)) diff --git a/ocaml/tests/test_helpers.ml b/ocaml/tests/test_helpers.ml index 42028c0d072..b856bb363e3 100644 --- a/ocaml/tests/test_helpers.ml +++ b/ocaml/tests/test_helpers.ml @@ -320,6 +320,14 @@ module IPCheckers = Generic.MakeStateless (struct ; ( (`ipv6, "address5", "ze80::bae8:56ff:fe29:894a") , Error (Server_error (invalid_ip_address_specified, ["address5"])) ) + ; ((`ipv4or6, "address5", "192.168.0.1"), Ok ()) + ; ((`ipv4or6, "address6", "fe80::bae8:56ff:fe29:894a"), Ok ()) + ; ( (`ipv4or6, "address7", "ze80::bae8:56ff:fe29:894a") + , Error (Server_error (invalid_ip_address_specified, ["address7"])) + ) + ; ( (`ipv4or6, "address8", "192.168.0.300") + , Error (Server_error (invalid_ip_address_specified, ["address8"])) + ) ] end) @@ -399,6 +407,17 @@ module CIDRCheckers = Generic.MakeStateless (struct ; ( (`ipv6, "address5", "ze80::bae8:56ff:fe29:894a/64") , Error (Server_error (invalid_cidr_address_specified, ["address5"])) ) + ; ( (`ipv4or6, "address6", "bad-address/64") + , Error (Server_error (invalid_cidr_address_specified, ["address6"])) + ) + ; ((`ipv4or6, "address7", "fe80::bae8:56ff:fe29:894a/64"), Ok ()) + ; ( (`ipv4or6, "address8", "ze80::bae8:56ff:fe29:894a/64") + , Error (Server_error (invalid_cidr_address_specified, ["address8"])) + ) + ; ((`ipv4or6, "address9", "255.255.255.0/32"), Ok ()) + ; ( (`ipv4or6, "address10", "192.168.0.2/33") + , Error (Server_error (invalid_cidr_address_specified, ["address10"])) + ) ] end) diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index e10c76ea4c3..8f583541481 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -13,6 +13,7 @@ rresult sexplib sexplib0 + uri tar threads.posix xapi-backtrace diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 92322264e36..105615fedfd 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -15,6 +15,9 @@ exception Record_failure of string +let record_failure fmt = + Printf.ksprintf (fun msg -> raise (Record_failure msg)) fmt + let to_str = function Rpc.String x -> x | _ -> failwith "Invalid" let certificate_type_to_string = function @@ -157,7 +160,7 @@ let vm_uefi_mode_of_string = function | "user" -> `user | s -> - raise (Record_failure ("Expected 'user','setup', got " ^ s)) + record_failure "Expected 'user','setup', got %s" s let vm_secureboot_readiness_to_string = function | `not_supported -> @@ -385,12 +388,8 @@ let string_to_vif_locking_mode = function | "disabled" -> `disabled | s -> - raise - (Record_failure - ("Expected 'network_default', 'locked', 'unlocked', 'disabled', got " - ^ s - ) - ) + record_failure + "Expected 'network_default', 'locked', 'unlocked', 'disabled', got %s" s let vmss_type_to_string = function | `snapshot -> @@ -408,12 +407,8 @@ let string_to_vmss_type = function | "snapshot_with_quiesce" -> `snapshot_with_quiesce | s -> - raise - (Record_failure - ("Expected 'snapshot', 'checkpoint', 'snapshot_with_quiesce', got " - ^ s - ) - ) + record_failure + "Expected 'snapshot', 'checkpoint', 'snapshot_with_quiesce', got %s" s let vmss_frequency_to_string = function | `hourly -> @@ -431,7 +426,7 @@ let string_to_vmss_frequency = function | "weekly" -> `weekly | s -> - raise (Record_failure ("Expected 'hourly', 'daily', 'weekly', got " ^ s)) + record_failure "Expected 'hourly', 'daily', 'weekly', got %s" s let network_default_locking_mode_to_string = function | `unlocked -> @@ -445,7 +440,7 @@ let string_to_network_default_locking_mode = function | "disabled" -> `disabled | s -> - raise (Record_failure ("Expected 'unlocked' or 'disabled', got " ^ s)) + record_failure "Expected 'unlocked' or 'disabled', got %s" s let network_purpose_to_string : API.network_purpose -> string = function | `nbd -> @@ -459,7 +454,7 @@ let string_to_network_purpose : string -> API.network_purpose = function | "insecure_nbd" -> `insecure_nbd | s -> - raise (Record_failure ("Expected a network purpose string; got " ^ s)) + record_failure "Expected a network purpose string; got %s" s let vm_appliance_operation_to_string = function | `start -> @@ -647,7 +642,7 @@ let string_to_on_normal_exit s = | "restart" -> `restart | _ -> - raise (Record_failure ("Expected 'destroy' or 'restart', got " ^ s)) + record_failure "Expected 'destroy' or 'restart', got %s" s let on_crash_behaviour_to_string x = match x with @@ -679,14 +674,11 @@ let string_to_on_crash_behaviour s = | "rename_restart" -> `rename_restart | _ -> - raise - (Record_failure - ("Expected 'destroy', 'coredump_and_destroy'," - ^ "'restart', 'coredump_and_restart', 'preserve' or \ - 'rename_restart', got " - ^ s - ) - ) + record_failure + "Expected 'destroy', 'coredump_and_destroy', \ + 'restart','coredump_and_restart', 'preserve' or 'rename_restart', got \ + %s" + s let on_softreboot_behaviour_to_string x = match x with @@ -710,14 +702,11 @@ let string_to_on_softreboot_behaviour s = | "soft_reboot" -> `soft_reboot | _ -> - raise - (Record_failure - ("Expected 'destroy', 'coredump_and_destroy'," - ^ "'restart', 'coredump_and_restart', 'preserve', 'soft_reboot' or \ - 'rename_restart', got " - ^ s - ) - ) + record_failure + "Expected 'destroy', 'coredump_and_destroy', 'restart', \ + 'coredump_and_restart', 'preserve', 'soft_reboot' or \ + 'rename_restart', got %s" + s let host_display_to_string h = match h with @@ -739,7 +728,7 @@ let host_sched_gran_of_string s = | "socket" -> `socket | _ -> - raise (Record_failure ("Expected 'core','cpu', 'socket', got " ^ s)) + record_failure "Expected 'core','cpu', 'socket', got %s" s let host_sched_gran_to_string = function | `core -> @@ -757,7 +746,8 @@ let host_numa_affinity_policy_to_string = function | `default_policy -> "default_policy" -let host_numa_affinity_policy_of_string = function +let host_numa_affinity_policy_of_string a = + match String.lowercase_ascii a with | "any" -> `any | "best_effort" -> @@ -765,10 +755,8 @@ let host_numa_affinity_policy_of_string = function | "default_policy" -> `default_policy | s -> - raise - (Record_failure - ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) - ) + record_failure "Expected 'any', 'best_effort' or 'default_policy', got %s" + s let pci_dom0_access_to_string x = host_display_to_string x @@ -779,7 +767,7 @@ let string_to_vdi_onboot s = | "reset" -> `reset | _ -> - raise (Record_failure ("Expected 'persist' or 'reset', got " ^ s)) + record_failure "Expected 'persist' or 'reset', got %s" s let string_to_vbd_mode s = match String.lowercase_ascii s with @@ -788,7 +776,7 @@ let string_to_vbd_mode s = | "rw" -> `RW | _ -> - raise (Record_failure ("Expected 'RO' or 'RW', got " ^ s)) + record_failure "Expected 'RO' or 'RW', got %s" s let vbd_mode_to_string = function `RO -> "ro" | `RW -> "rw" @@ -801,7 +789,7 @@ let string_to_vbd_type s = | "floppy" -> `Floppy | _ -> - raise (Record_failure ("Expected 'CD' or 'Disk', got " ^ s)) + record_failure "Expected 'CD' or 'Disk', got %s" s let power_to_string h = match h with @@ -860,7 +848,7 @@ let ip_configuration_mode_of_string m = | "static" -> `Static | s -> - raise (Record_failure ("Expected 'dhcp','none' or 'static', got " ^ s)) + record_failure "Expected 'dhcp','none' or 'static', got %s" s let vif_ipv4_configuration_mode_to_string = function | `None -> @@ -875,7 +863,7 @@ let vif_ipv4_configuration_mode_of_string m = | "static" -> `Static | s -> - raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + record_failure "Expected 'none' or 'static', got %s" s let ipv6_configuration_mode_to_string = function | `None -> @@ -898,10 +886,7 @@ let ipv6_configuration_mode_of_string m = | "autoconf" -> `Autoconf | s -> - raise - (Record_failure - ("Expected 'dhcp','none' 'autoconf' or 'static', got " ^ s) - ) + record_failure "Expected 'dhcp','none' 'autoconf' or 'static', got %s" s let vif_ipv6_configuration_mode_to_string = function | `None -> @@ -916,7 +901,7 @@ let vif_ipv6_configuration_mode_of_string m = | "static" -> `Static | s -> - raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + record_failure "Expected 'none' or 'static', got %s" s let primary_address_type_to_string = function | `IPv4 -> @@ -931,7 +916,7 @@ let primary_address_type_of_string m = | "ipv6" -> `IPv6 | s -> - raise (Record_failure ("Expected 'ipv4' or 'ipv6', got " ^ s)) + record_failure "Expected 'ipv4' or 'ipv6', got %s" s let bond_mode_to_string = function | `balanceslb -> @@ -950,7 +935,7 @@ let bond_mode_of_string m = | "lacp" -> `lacp | s -> - raise (Record_failure ("Invalid bond mode. Got " ^ s)) + record_failure "Invalid bond mode. Got %s" s let allocation_algorithm_to_string = function | `depth_first -> @@ -965,7 +950,7 @@ let allocation_algorithm_of_string a = | "breadth-first" -> `breadth_first | s -> - raise (Record_failure ("Invalid allocation algorithm. Got " ^ s)) + record_failure "Invalid allocation algorithm. Got %s" s let pvs_proxy_status_to_string = function | `stopped -> @@ -991,12 +976,8 @@ let bool_of_string s = | "false" | "f" | "no" | "n" | "0" -> false | _ -> - raise - (Record_failure - ("Expected 'true','t','yes','y','1','false','f','no','n','0' got " - ^ s - ) - ) + record_failure + "Expected 'true','t','yes','y','1','false','f','no','n','0' got %s" s let sdn_protocol_of_string s = match String.lowercase_ascii s with @@ -1005,7 +986,7 @@ let sdn_protocol_of_string s = | "pssl" -> `pssl | _ -> - raise (Record_failure ("Expected 'ssl','pssl', got " ^ s)) + record_failure "Expected 'ssl','pssl', got %s" s let sdn_protocol_to_string = function `ssl -> "ssl" | `pssl -> "pssl" @@ -1016,7 +997,7 @@ let tunnel_protocol_of_string s = | "vxlan" -> `vxlan | _ -> - raise (Record_failure ("Expected 'gre','vxlan', got " ^ s)) + record_failure "Expected 'gre','vxlan', got %s" s let tunnel_protocol_to_string = function `gre -> "gre" | `vxlan -> "vxlan" @@ -1089,119 +1070,42 @@ let domain_type_of_string x = | "pvh" -> `pvh | s -> - raise (Record_failure ("Invalid domain type. Got " ^ s)) + record_failure "Invalid domain type. Got %s" s let vtpm_operation_to_string (op : API.vtpm_operations) = match op with `destroy -> "destroy" -(** Parse a string which might have a units suffix on the end *) -let bytes_of_string field x = +(** parse [0-9]*(b|bytes|kib|mib|gib|tib)* to bytes *) +let bytes_of_string str = let ( ** ) a b = Int64.mul a b in - let max_size_TiB = - Int64.div Int64.max_int (1024L ** 1024L ** 1024L ** 1024L) - in - (* detect big number that cannot be represented by Int64. *) - let int64_of_string s = - try Int64.of_string s - with _ -> - if s = "" then - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer (possibly \ - with suffix)" - field - ) - ) ; - let alldigit = ref true and i = ref (String.length s - 1) in - while !alldigit && !i > 0 do - alldigit := Astring.Char.Ascii.is_digit s.[!i] ; - decr i - done ; - if !alldigit then - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': number too big (maximum = %Ld TiB)" - field max_size_TiB - ) - ) - else - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer (possibly \ - with suffix)" - field - ) - ) - in - match - Astring.( - String.fields ~empty:false ~is_sep:(fun c -> - Char.Ascii.(is_white c || is_digit c) - ) - ) - x - with - | [] -> - (* no suffix on the end *) - int64_of_string x - | [suffix] -> - let number = - match - Astring.( - String.fields ~empty:false ~is_sep:(Fun.negate Char.Ascii.is_digit) - ) - x - with - | [number] -> - int64_of_string number - | _ -> - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer \ - (possibly with suffix)" - field - ) - ) - in - let multiplier = - match suffix with - | "bytes" -> - 1L - | "KiB" -> - 1024L - | "MiB" -> - 1024L ** 1024L - | "GiB" -> - 1024L ** 1024L ** 1024L - | "TiB" -> - 1024L ** 1024L ** 1024L ** 1024L - | x -> - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': Unknown suffix: '%s' (try \ - KiB, MiB, GiB or TiB)" - field x - ) - ) - in - (* FIXME: detect overflow *) - number ** multiplier - | _ -> - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer (possibly with \ - suffix)" - field - ) - ) + let invalid msg = raise (Invalid_argument msg) in + try + Scanf.sscanf str "%Ld %s" @@ fun size suffix -> + match String.lowercase_ascii suffix with + | _ when size < 0L -> + invalid str + | "bytes" | "b" | "" -> + size + | "kib" | "kb" | "k" -> + size ** 1024L + | "mib" | "mb" | "m" -> + size ** 1024L ** 1024L + | "gib" | "gb" | "g" -> + size ** 1024L ** 1024L ** 1024L + | "tib" | "tb" | "t" -> + size ** 1024L ** 1024L ** 1024L ** 1024L + | _ -> + invalid suffix + with _ -> invalid str -(* Vincent's random mac utils *) +(** Parse a string which might have a units suffix on the end *) +let bytes_of_string field x = + try bytes_of_string x + with Invalid_argument _ -> + record_failure + "Failed to parse field '%s': expecting an integer (possibly with suffix \ + KiB, MiB, GiB, TiB), got '%s'" + field x let mac_from_int_array macs = (* make sure bit 1 (local) is set and bit 0 (unicast) is clear *) @@ -1225,7 +1129,7 @@ let update_sync_frequency_of_string s = | "weekly" -> `weekly | _ -> - raise (Record_failure ("Expected 'daily', 'weekly', got " ^ s)) + record_failure "Expected 'daily', 'weekly', got %s" s let vm_placement_policy_to_string = function | `normal -> @@ -1240,4 +1144,4 @@ let vm_placement_policy_of_string a = | "anti-affinity" -> `anti_affinity | s -> - raise (Record_failure ("Invalid VM placement policy, got " ^ s)) + record_failure "Invalid VM placement policy, got %s" s diff --git a/ocaml/xapi-client/dune b/ocaml/xapi-client/dune index 9951eb6cfbc..d85c2af74af 100644 --- a/ocaml/xapi-client/dune +++ b/ocaml/xapi-client/dune @@ -15,7 +15,7 @@ (libraries mtime mtime.clock.os - rpclib.core + (re_export rpclib.core) xapi-consts xapi-log xapi-types diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index 052810ead5f..dd35baf40cb 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -6,13 +6,22 @@ cohttp-lwt cohttp-lwt-unix conduit-lwt-unix + fmt + log lwt lwt.unix + mtime + mtime.clock + mtime.clock.os result rpclib.core rpclib-lwt + rpclib.xml + uuidm + uri xapi_guard xapi-idl.xen.interface + xapi-idl.guard.varstored xapi-log xapi-types xen-api-client-lwt @@ -23,10 +32,18 @@ (modules dorpc types disk_cache lwt_bounded_stream) (libraries rpclib.core + fmt inotify inotify.lwt + rresult + result + log lwt lwt.unix + mtime + mtime.clock + mtime.clock.os + uuidm uri xapi-backtrace xapi-consts diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index baac1d24101..ac7a6665c1a 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -20,6 +20,7 @@ xapi-idl.guard.privileged xapi-log xapi-types + xapi_version xen-api-client-lwt) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-guard/test/dune b/ocaml/xapi-guard/test/dune index e082a47a690..9d44fdefbac 100644 --- a/ocaml/xapi-guard/test/dune +++ b/ocaml/xapi-guard/test/dune @@ -15,6 +15,7 @@ xapi_guard_server xapi-log xapi-types + xapi_version xen-api-client-lwt) (package varstored-guard) ) @@ -23,6 +24,7 @@ (name cache_test) (modules cache_test) (libraries + fmt logs logs.fmt logs.lwt @@ -30,6 +32,8 @@ lwt.unix mtime mtime.clock.os + result uuidm + xapi-log xapi_guard) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-idl/guard/varstored/dune b/ocaml/xapi-idl/guard/varstored/dune index 0e6bd85b627..a54af22988a 100644 --- a/ocaml/xapi-idl/guard/varstored/dune +++ b/ocaml/xapi-idl/guard/varstored/dune @@ -3,7 +3,7 @@ (public_name xapi-idl.guard.varstored) (modules (:standard \ varstored_cli)) (libraries - rpclib.core + (re_export rpclib.core) threads xapi-idl.xen xapi-idl.xen.interface diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index 91c72783c42..c8feec1ff1a 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -51,6 +51,7 @@ rpclib.json sexplib sexplib0 + tracing threads.posix xapi-backtrace xapi-idl diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index de6906fdfcd..57c8c95e592 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -2,7 +2,7 @@ (name test_lib) (modules idl_test_common) (libraries - alcotest xapi-idl) + (re_export alcotest) xapi-idl (re_export rpclib.core) rpclib.json rpclib.xml result) (wrapped false) ) @@ -26,6 +26,7 @@ (deps (source_tree test_data)) (libraries alcotest + cohttp_posix fmt result rpclib.core @@ -34,6 +35,7 @@ rpclib.xml test_lib threads.posix + xapi-idl xapi-idl.cluster xapi-idl.rrd xapi-idl.memory diff --git a/ocaml/xapi-idl/network/dune b/ocaml/xapi-idl/network/dune index 4fb1a78f213..eb321c114e3 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -10,6 +10,7 @@ threads.posix xapi-idl xapi-log + ipaddr ) (wrapped false) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-idl/network/network_interface.ml b/ocaml/xapi-idl/network/network_interface.ml index 8fd2553ea07..6b27e31f5bf 100644 --- a/ocaml/xapi-idl/network/network_interface.ml +++ b/ocaml/xapi-idl/network/network_interface.ml @@ -34,19 +34,27 @@ let comp f g x = f (g x) let ( ++ ) f g x = comp f g x let netmask_to_prefixlen netmask = - Scanf.sscanf netmask "%d.%d.%d.%d" (fun a b c d -> - let rec length l x = if x > 0 then length (succ l) (x lsr 1) else l in - let masks = List.map (( - ) 255) [a; b; c; d] in - 32 - List.fold_left length 0 masks + let raise_on_ipaddr_err = function + | `Msg str -> + failwith + (Printf.sprintf "%s: Failed to parse the netmask %s (%s)" __FUNCTION__ + netmask str + ) + in + Ipaddr.V4.( + match of_string netmask with + | Ok ip_t -> ( + match Prefix.of_netmask ~address:ip_t ~netmask:ip_t with + | Ok x -> + Prefix.bits x + | Error e -> + raise_on_ipaddr_err e + ) + | Error e -> + raise_on_ipaddr_err e ) -let prefixlen_to_netmask len = - let mask l = - if l <= 0 then 0 else if l > 8 then 255 else 256 - (1 lsl (8 - l)) - in - let lens = [len; len - 8; len - 16; len - 24] in - let masks = List.map (string_of_int ++ mask) lens in - String.concat "." masks +let prefixlen_to_netmask len = Ipaddr.V4.(Prefix.mask len |> to_string) module Unix = struct include Unix 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/certificates.ml b/ocaml/xapi/certificates.ml index 4f6747762ea..effb154877e 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -80,6 +80,9 @@ let pp_hash hash = in String.init length value_of +let pp_fingerprint ~hash_type cert = + X509.Certificate.fingerprint hash_type cert |> pp_hash + let safe_char c = match c with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '.' | '_' | '-' -> @@ -218,12 +221,8 @@ end = struct let not_before, not_after = dates_of_ptimes (X509.Certificate.validity certificate) in - let fingerprint_sha256 = - X509.Certificate.fingerprint `SHA256 certificate |> pp_hash - in - let fingerprint_sha1 = - X509.Certificate.fingerprint `SHA1 certificate |> pp_hash - in + let fingerprint_sha256 = pp_fingerprint ~hash_type:`SHA256 certificate in + let fingerprint_sha1 = pp_fingerprint ~hash_type:`SHA1 certificate in let uuid = Uuidx.(to_string (make ())) in let ref' = Ref.make () in Db.Certificate.create ~__context ~ref:ref' ~uuid ~host ~not_before diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index ddb2677df1c..486ada825e2 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -20,6 +20,9 @@ val pem_of_string : string -> X509.Certificate.t val pp_hash : Cstruct.t -> string +val pp_fingerprint : + hash_type:Mirage_crypto.Hash.hash -> X509.Certificate.t -> string + val validate_name : t_trusted -> string -> unit val hostnames_of_pem_cert : diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index 735b1a9c936..e1bf42630a0 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -29,16 +29,26 @@ let install ~__context ~host:_ ~type' cert = error "certificates_sync.install exception: %s" (Printexc.to_string e) ; Error (`Msg ("installation of host certificate failed", [])) +type to_update = Certificate | Hashes of {sha256: string; sha1: string} + (** determine if the database is up to date by comparing the fingerprint of xapi-ssl.pem with the entry in the database *) -let is_unchanged ~__context cert_ref cert = +let to_update ~__context cert_ref cert = let ref_hash = Db.Certificate.get_fingerprint_sha256 ~__context ~self:cert_ref in - let cert_hash = - X509.Certificate.fingerprint `SHA256 cert |> Certificates.pp_hash - in - cert_hash = ref_hash + let sha256 = Certificates.pp_fingerprint ~hash_type:`SHA256 cert in + if ref_hash = "" then + (* We must be upgrading from a version predating fingerprint_sha256, so check fingerprint instead *) + if sha256 = Db.Certificate.get_fingerprint ~__context ~self:cert_ref then + let sha1 = Certificates.pp_fingerprint ~hash_type:`SHA1 cert in + Some (Hashes {sha256; sha1}) + else + Some Certificate + else if sha256 = ref_hash then + None + else + Some Certificate (** [get_server_cert] loads [path] from the file system and returns it decoded *) @@ -76,17 +86,26 @@ let sync ~__context ~type' = | [] -> info "Host %s has no active server certificate" host_uuid ; install ~__context ~host ~type' cert - | [cert_ref] -> - let unchanged = is_unchanged ~__context cert_ref cert in - if unchanged then ( - info "Active server certificate for host %s is unchanged" host_uuid ; - Ok () - ) else ( + | [cert_ref] -> ( + match to_update ~__context cert_ref cert with + | Some Certificate -> info "Server certificate for host %s changed - updating" host_uuid ; let* () = install ~__context ~host ~type' cert in uninstall ~__context cert_ref ; Ok () - ) + | Some (Hashes {sha256; sha1}) -> + info "Active server certificate for host %s is unchanged" host_uuid ; + Db.Certificate.set_fingerprint_sha256 ~__context ~self:cert_ref + ~value:sha256 ; + Db.Certificate.set_fingerprint_sha1 ~__context ~self:cert_ref + ~value:sha1 ; + info "Populated new fingerprint fields: sha256= %s; sha1= %s" sha256 + sha1 ; + Ok () + | None -> + info "Active server certificate for host %s is unchanged" host_uuid ; + Ok () + ) | cert_refs -> warn "The host has more than one certificate: %s" (String.concat ", " (List.map Ref.string_of cert_refs)) ; diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 7492df39e68..22b37b509ac 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -64,7 +64,9 @@ astring cstruct base64 + clock cohttp + cohttp_posix domain-name ezxenstore.core fmt @@ -73,7 +75,9 @@ gzip hex http_lib + httpsvr ipaddr + ipaddr.unix magic-mime message-switch-core message-switch-unix @@ -86,6 +90,7 @@ pci psq ptime + ptime.clock.os rpclib.core rpclib.json rpclib.xml @@ -112,7 +117,7 @@ x509 xapi_aux xapi-backtrace - xapi-consts + (re_export xapi-consts) xapi-consts.xapi_version xapi-client xapi-cli-protocol @@ -139,7 +144,7 @@ xapi-log xapi-open-uri xapi-rrd - xapi-types + (re_export xapi-types) xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives @@ -148,6 +153,7 @@ xapi-stdext-unix xapi-stdext-zerocheck xapi-tracing + xapi-tracing-export xapi-xenopsd xenstore_transport.unix xml-light2 diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 6c0a5d59075..c3111cae93a 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1114,31 +1114,55 @@ let assert_is_valid_ip kind field address = if not (is_valid_ip kind address) then raise Api_errors.(Server_error (invalid_ip_address_specified, [field])) +module type AbstractIpaddr = sig + type t + + module Prefix : sig + type addr = t + + type t + + val of_string : string -> (t, [> `Msg of string]) result + + val address : t -> addr + + val bits : t -> int + end + + val to_string : t -> string +end + let parse_cidr kind cidr = - try - let address, prefixlen = Scanf.sscanf cidr "%s@/%d" (fun a p -> (a, p)) in - if not (is_valid_ip kind address) then ( - error "Invalid address in CIDR (%s)" address ; - None - ) else if - prefixlen < 0 - || (kind = `ipv4 && prefixlen > 32) - || (kind = `ipv6 && prefixlen > 128) - then ( - error "Invalid prefix length in CIDR (%d)" prefixlen ; - None - ) else + let select_ip_family = function + | `ipv4 -> + (module Ipaddr.V4 : AbstractIpaddr) + | `ipv6 -> + (module Ipaddr.V6) + in + let module AddrParse = (val select_ip_family kind) in + match AddrParse.Prefix.of_string cidr with + | Ok ip_t -> + let address = AddrParse.Prefix.address ip_t |> AddrParse.to_string in + let prefixlen = AddrParse.Prefix.bits ip_t in Some (address, prefixlen) - with _ -> - error "Invalid CIDR format (%s)" cidr ; - None + | Error e -> + let msg = match e with `Msg str -> str in + error "Invalid address in CIDR (%s). %s" cidr msg ; + None + +let valid_cidr_aux kind cidr = + match kind with + | `ipv4or6 -> + parse_cidr `ipv4 cidr = None && parse_cidr `ipv6 cidr = None + | (`ipv4 | `ipv6) as kind -> + parse_cidr kind cidr = None let assert_is_valid_cidr kind field cidr = - if parse_cidr kind cidr = None then + if valid_cidr_aux kind cidr then raise Api_errors.(Server_error (invalid_cidr_address_specified, [field])) let assert_is_valid_ip_addr kind field address = - if (not (is_valid_ip kind address)) && parse_cidr kind address = None then + if (not (is_valid_ip kind address)) && valid_cidr_aux kind address then raise Api_errors.(Server_error (invalid_ip_address_specified, [field])) (** Return true if the MAC is in the right format XX:XX:XX:XX:XX:XX *) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index e323bd4248b..34e420259b8 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -6419,6 +6419,14 @@ functor ) ; debug "Cluster.pool_resync for host %s" (Ref.string_of host) ) + + let cstack_sync ~__context ~self = + info "Cluster.cstack_sync cluster %s" (Ref.string_of self) ; + let local_fn = Local.Cluster.cstack_sync ~self in + let coor = Helpers.get_master ~__context in + do_op_on ~local_fn ~__context ~host:coor (fun session_id rpc -> + Client.Cluster.cstack_sync ~rpc ~session_id ~self + ) end module Cluster_host = struct diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index 5db9cb9a29f..d2f121bd3f1 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -613,18 +613,18 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) let addresses = List.filter_map (fun addr_and_prefixlen -> - try - let n = String.index addr_and_prefixlen '/' in - let addr = - Unix.inet_addr_of_string - (String.sub addr_and_prefixlen 0 n) + let ( let* ) = Option.bind in + Ipaddr.V6.( + let* ip_t = + Result.to_option + (Prefix.of_string addr_and_prefixlen) in - let prefixlen = - int_of_string - (String.sub_to_end addr_and_prefixlen (n + 1)) + let addr = + Prefix.address ip_t |> Ipaddr_unix.V6.to_inet_addr in + let prefixlen = Prefix.bits ip_t in Some (addr, prefixlen) - with _ -> None + ) ) rc.API.pIF_IPv6 in @@ -714,9 +714,16 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) | [] -> "" | hd :: _ -> ( - (* IPv6 addresses are stored with this format: / *) - match String.split_on_char '/' hd with [ip; _] -> ip | _ -> "" - ) + (* IPv6 addresses are stored with this format: / *) + Ipaddr.V6.( + match Prefix.of_string hd with + | Ok ip_t -> + Prefix.address ip_t |> to_string + | _ -> + debug "%s not an IPv6 prefix: %s" __FUNCTION__ hd ; + "" + ) + ) ) in if new_ip <> pif_ip then ( diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 128910151ed..0b1c213e993 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -930,12 +930,20 @@ let report_tls_verification ~__context = let value = Stunnel_client.get_verify_by_default () in Db.Host.set_tls_verification_enabled ~__context ~self ~value +let test_open count = + if count > 0 then ( + debug "%s: opening %d file descriptors" __FUNCTION__ count ; + Xapi_stdext_unix.Unixext.test_open count ; + debug "%s: opened %d files" __FUNCTION__ count + ) + let server_init () = let print_server_starting_message () = debug "(Re)starting xapi, pid: %d" (Unix.getpid ()) ; debug "on_system_boot=%b pool_role=%s" !Xapi_globs.on_system_boot (Pool_role.string_of (Pool_role.get_role ())) in + test_open !Xapi_globs.test_open ; Unixext.unlink_safe "/etc/xensource/boot_time_info_updated" ; (* Record the initial value of Master_connection.connection_timeout and set it to 'never'. When we are a slave who has just started up we want to wait forever for the master to appear. (See CA-25481) *) @@ -1533,12 +1541,11 @@ let delay_on_eintr f = Backtrace.is_important e ; raise e let watchdog f = - if !Xapi_globs.nowatchdog then ( - try - ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigint]) ; - delay_on_eintr f ; - exit 127 - with e -> - Debug.log_backtrace e (Backtrace.get e) ; - exit 2 - ) + let run () = + ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigint]) ; + delay_on_eintr f ; + exit 127 + in + if !Xapi_globs.nowatchdog then + (* backtrace already logged by the Debug module, so ignore the exception here *) + try Debug.with_thread_associated __FUNCTION__ run () with _ -> exit 2 diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index dda26d201f4..cfa55fde2c7 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -115,7 +115,7 @@ let create ~__context ~pIF ~cluster_stack ~pool_auto_join ~token_timeout ~verify ; (* Create the watcher here in addition to resync_host since pool_create in resync_host only calls cluster_host.create for pool member nodes *) - create_cluster_watcher_on_master ~__context ~host ; + Watcher.create_as_necessary ~__context ~host ; Xapi_cluster_host_helpers.update_allowed_operations ~__context ~self:cluster_host_ref ; D.debug "Created Cluster: %s and Cluster_host: %s" @@ -294,3 +294,10 @@ let pool_resync ~__context ~self:_ = ) (* If host.clustering_enabled then resync_host should successfully find or create a matching cluster_host which is also enabled *) + +let cstack_sync ~__context ~self = + if Xapi_cluster_helpers.cluster_health_enabled ~__context then ( + debug "%s: sync db data with cluster stack" __FUNCTION__ ; + Watcher.on_corosync_update ~__context ~cluster:self + ["Updates due to cluster api calls"] + ) diff --git a/ocaml/xapi/xapi_cluster.mli b/ocaml/xapi/xapi_cluster.mli index a9a71f275ad..bcdc029c49b 100644 --- a/ocaml/xapi/xapi_cluster.mli +++ b/ocaml/xapi/xapi_cluster.mli @@ -74,3 +74,13 @@ val pool_resync : __context:Context.t -> self:API.ref_Cluster -> unit Cluster_host objects (ie., one for each host in the pool if the Cluster has [pool_auto_join] set. If there is a failure, this function must return an error that enables the administrator to fix the problem. *) + +val cstack_sync : __context:Context.t -> self:API.ref_Cluster -> unit +(** [cstack_sync ~__context ~self] is the implementation of the internal XenAPI method, +which synchronously performs a diagnostics call to xapi-clusterd and updates the +xapi db according to the call. This is used internally by cluster-host-create/destroy +to generate the correct alert as a result of the API call. The other part of the +alerts generated due to network failure (e.g. a host left as its network is down) +is handled by the cluster watcher. This call only happens on the coordinator as that +is where the cluster watcher performs the updates, which shares the code with +this function. *) diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index 31a655a3e72..f7ea78eab9d 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -114,7 +114,7 @@ let corosync3_enabled ~__context = let restrictions = Db.Pool.get_restrictions ~__context ~self:pool in List.assoc_opt "restrict_corosync3" restrictions = Some "false" -let maybe_generate_alert ~__context ~num_hosts ~missing_hosts ~new_hosts ~quorum +let maybe_generate_alert ~__context ~num_hosts ~hosts_left ~hosts_joined ~quorum = let generate_alert join cluster_host = let host = Db.Cluster_host.get_host ~__context ~self:cluster_host in @@ -148,10 +148,10 @@ let maybe_generate_alert ~__context ~num_hosts ~missing_hosts ~new_hosts ~quorum ) in if cluster_health_enabled ~__context then ( - List.iter (generate_alert false) missing_hosts ; - List.iter (generate_alert true) new_hosts ; + List.iter (generate_alert false) hosts_left ; + List.iter (generate_alert true) hosts_joined ; (* only generate this alert when the number of hosts is decreasing *) - if missing_hosts <> [] && num_hosts <= quorum then + if hosts_left <> [] && num_hosts <= quorum then let pool = Helpers.get_pool ~__context in let pool_uuid = Db.Pool.get_uuid ~__context ~self:pool in let name, priority = Api_messages.cluster_quorum_approaching_lost in diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index 782d5a240f5..c55d789b8d9 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -13,7 +13,6 @@ *) open Xapi_clustering -open Xapi_cluster_helpers open Ipaddr_rpc_type module D = Debug.Make (struct let name = "xapi_cluster_host" end) @@ -55,20 +54,6 @@ let call_api_function_with_alert ~__context ~msg ~cls ~obj_uuid ~body raise err ) -let alert_for_cluster_host ~__context ~cluster_host ~missing_hosts ~new_hosts = - let num_hosts = Db.Cluster_host.get_all ~__context |> List.length in - let cluster = Db.Cluster_host.get_cluster ~__context ~self:cluster_host in - let quorum = Db.Cluster.get_quorum ~__context ~self:cluster |> Int64.to_int in - maybe_generate_alert ~__context ~missing_hosts ~new_hosts ~num_hosts ~quorum - -let alert_for_cluster_host_leave ~__context ~cluster_host = - alert_for_cluster_host ~__context ~cluster_host ~missing_hosts:[cluster_host] - ~new_hosts:[] - -let alert_for_cluster_host_join ~__context ~cluster_host = - alert_for_cluster_host ~__context ~cluster_host ~missing_hosts:[] - ~new_hosts:[cluster_host] - (* Create xapi db object for cluster_host, resync_host calls clusterd *) let create_internal ~__context ~cluster ~host ~pIF : API.ref_Cluster_host = with_clustering_lock __LOC__ (fun () -> @@ -81,7 +66,6 @@ let create_internal ~__context ~cluster ~host ~pIF : API.ref_Cluster_host = ~enabled:false ~current_operations:[] ~allowed_operations:[] ~other_config:[] ~joined:false ~live:false ~last_update_live:API.Date.epoch ; - alert_for_cluster_host_join ~__context ~cluster_host:ref ; ref ) @@ -232,7 +216,7 @@ let resync_host ~__context ~host = (* If we have just joined, enable will prevent concurrent clustering ops *) if not (Db.Cluster_host.get_joined ~__context ~self) then ( join_internal ~__context ~self ; - create_cluster_watcher_on_master ~__context ~host ; + Watcher.create_as_necessary ~__context ~host ; Xapi_observer.initialise_observer ~__context Xapi_observer_components.Xapi_clusterd ) else if Db.Cluster_host.get_enabled ~__context ~self then ( @@ -269,16 +253,21 @@ let destroy_op ~__context ~self ~force = (Cluster_client.LocalClient.leave, "destroy") in let result = local_fn (rpc ~__context) dbg in + let cluster = Db.Cluster_host.get_cluster ~__context ~self in match Idl.IdM.run @@ Cluster_client.IDL.T.get result with | Ok () -> - alert_for_cluster_host_leave ~__context ~cluster_host:self ; + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.cstack_sync ~rpc ~session_id ~self:cluster + ) ; Db.Cluster_host.destroy ~__context ~self ; debug "Cluster_host.%s was successful" fn_str ; Xapi_clustering.Daemon.disable ~__context | Error error -> warn "Error occurred during Cluster_host.%s" fn_str ; if force then ( - alert_for_cluster_host_leave ~__context ~cluster_host:self ; + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.cstack_sync ~rpc ~session_id ~self:cluster + ) ; let ref_str = Ref.string_of self in Db.Cluster_host.destroy ~__context ~self ; debug "Cluster_host %s force destroyed." ref_str @@ -326,7 +315,9 @@ let forget ~__context ~self = Db.Cluster.set_pending_forget ~__context ~self:cluster ~value:[] ; (* must not disable the daemon here, because we declared another unreachable node dead, * not the current one *) - alert_for_cluster_host_leave ~__context ~cluster_host:self ; + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.cstack_sync ~rpc ~session_id ~self:cluster + ) ; Db.Cluster_host.destroy ~__context ~self ; debug "Cluster_host.forget was successful" | Error error -> @@ -375,7 +366,7 @@ let enable ~__context ~self = "Cluster_host.enable: xapi-clusterd not running - attempting to start" ; Xapi_clustering.Daemon.enable ~__context ) ; - create_cluster_watcher_on_master ~__context ~host ; + Watcher.create_as_necessary ~__context ~host ; Xapi_observer.initialise_observer ~__context Xapi_observer_components.Xapi_clusterd ; let verify = Stunnel_client.get_verify_by_default () in diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 4fc9314aa2e..21794537268 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -426,133 +426,169 @@ let compute_corosync_max_host_failures ~__context = in corosync_ha_max_hosts -let on_corosync_update ~__context ~cluster updates = - debug - "%s: Received %d updates from corosync_notifyd , run diagnostics to get \ - new state" - __FUNCTION__ (List.length updates) ; - let m = - Cluster_client.LocalClient.diagnostics (rpc ~__context) - "update quorum api fields with diagnostics" - in - match Idl.IdM.run @@ Cluster_client.IDL.T.get m with - | Ok diag -> - Db.Cluster.set_is_quorate ~__context ~self:cluster ~value:diag.is_quorate ; - let all_cluster_hosts = Db.Cluster_host.get_all ~__context in - let ip_ch = - List.map - (fun ch -> - let pIF = Db.Cluster_host.get_PIF ~__context ~self:ch in - let ipstr = - ip_of_pif (pIF, Db.PIF.get_record ~__context ~self:pIF) - |> ipstr_of_address - in - (ipstr, ch) - ) - all_cluster_hosts - in - let current_time = API.Date.now () in - ( match diag.quorum_members with - | None -> - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:false ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - all_cluster_hosts - | Some nodel -> - let quorum_hosts = - List.filter_map - (fun {addr; _} -> - let ipstr = ipstr_of_address addr in - match List.assoc_opt ipstr ip_ch with - | None -> - error - "%s: cannot find cluster host with network address %s, \ - ignoring this host" - __FUNCTION__ ipstr ; - None - | Some ch -> - Some ch - ) - nodel +module Watcher = struct + let on_corosync_update ~__context ~cluster updates = + debug + "%s: Received %d updates from corosync_notifyd, run diagnostics to get \ + new state" + __FUNCTION__ (List.length updates) ; + let m = + Cluster_client.LocalClient.diagnostics (rpc ~__context) + "update quorum api fields with diagnostics" + in + match Idl.IdM.run @@ Cluster_client.IDL.T.get m with + | Ok diag -> + ( Db.Cluster.set_is_quorate ~__context ~self:cluster + ~value:diag.is_quorate ; + let all_cluster_hosts = Db.Cluster_host.get_all ~__context in + let live_hosts = + Db.Cluster_host.get_refs_where ~__context + ~expr:(Eq (Field "live", Literal "true")) in - let missing_hosts = - List.filter - (fun h -> not (List.mem h quorum_hosts)) - all_cluster_hosts + let dead_hosts = + List.filter (fun h -> not (List.mem h live_hosts)) all_cluster_hosts in - let new_hosts = - List.filter - (fun h -> not (Db.Cluster_host.get_live ~__context ~self:h)) - quorum_hosts + let ip_ch = + List.map + (fun ch -> + let pIF = Db.Cluster_host.get_PIF ~__context ~self:ch in + let ipstr = + ip_of_pif (pIF, Db.PIF.get_record ~__context ~self:pIF) + |> ipstr_of_address + in + (ipstr, ch) + ) + all_cluster_hosts in - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:true ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - new_hosts ; - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:false ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - missing_hosts ; - maybe_generate_alert ~__context ~missing_hosts ~new_hosts - ~num_hosts:(List.length quorum_hosts) ~quorum:diag.quorum - ) ; - Db.Cluster.set_quorum ~__context ~self:cluster - ~value:(Int64.of_int diag.quorum) ; - Db.Cluster.set_live_hosts ~__context ~self:cluster - ~value:(Int64.of_int diag.total_votes) - | Error (InternalError message) | Error (Unix_error message) -> - warn "%s Cannot query diagnostics due to %s, not performing update" - __FUNCTION__ message - | exception exn -> - warn - "%s: Got exception %s while retrieving diagnostics info, not \ - performing update" - __FUNCTION__ (Printexc.to_string exn) - -let create_cluster_watcher_on_master ~__context ~host = - if Helpers.is_pool_master ~__context ~host then - let watch () = - while !Daemon.enabled do - let m = - Cluster_client.LocalClient.UPDATES.get (rpc ~__context) - "call cluster watcher" 3. - in - match Idl.IdM.run @@ Cluster_client.IDL.T.get m with - | Ok updates -> ( - match find_cluster_host ~__context ~host with - | Some ch -> - let cluster = Db.Cluster_host.get_cluster ~__context ~self:ch in - on_corosync_update ~__context ~cluster updates + let current_time = API.Date.now () in + match diag.quorum_members with | None -> - () - ) - | Error (InternalError "UPDATES.Timeout") -> - (* UPDATES.get timed out, this is normal, now retry *) + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:false ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) + all_cluster_hosts + | Some nodel -> + (* nodel contains the current members of the cluster, according to corosync *) + let quorum_hosts = + List.filter_map + (fun {addr; _} -> + let ipstr = ipstr_of_address addr in + match List.assoc_opt ipstr ip_ch with + | None -> + error + "%s: cannot find cluster host with network address \ + %s, ignoring this host" + __FUNCTION__ ipstr ; + None + | Some ch -> + Some ch + ) + nodel + in + + (* hosts_left contains the hosts that were live, but not in the list + of live hosts according to the cluster stack *) + let hosts_left = + List.filter (fun h -> not (List.mem h quorum_hosts)) live_hosts + in + (* hosts_joined contains the hosts that were dead but exists in the db, + and is now viewed as a member of the cluster by the cluster stack *) + let hosts_joined = + List.filter (fun h -> List.mem h quorum_hosts) dead_hosts + in + debug "%s: there are %d hosts joined and %d hosts left" + __FUNCTION__ (List.length hosts_joined) (List.length hosts_left) ; + + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:true ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) + quorum_hosts ; + List.filter + (fun h -> not (List.mem h quorum_hosts)) + all_cluster_hosts + |> List.iter (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:false ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) ; + maybe_generate_alert ~__context ~hosts_left ~hosts_joined + ~num_hosts:(List.length quorum_hosts) ~quorum:diag.quorum + ) ; + Db.Cluster.set_quorum ~__context ~self:cluster + ~value:(Int64.of_int diag.quorum) ; + Db.Cluster.set_live_hosts ~__context ~self:cluster + ~value:(Int64.of_int diag.total_votes) + | Error (InternalError message) | Error (Unix_error message) -> + warn "%s Cannot query diagnostics due to %s, not performing update" + __FUNCTION__ message + | exception exn -> + warn + "%s: Got exception %s while retrieving diagnostics info, not \ + performing update" + __FUNCTION__ (Printexc.to_string exn) + + let cluster_change_watcher : bool Atomic.t = Atomic.make false + + (* this is the time it takes for the update request to time out. It is ok to set + it to a relatively long value since the call will return immediately if there + is an update *) + let cluster_change_interval = Mtime.Span.min + + (* we handle unclean hosts join and leave in the watcher, i.e. hosts joining and leaving + due to network problems, power cut, etc. Join and leave initiated by the + API will be handled in the API call themselves, but they share the same code + as the watcher. *) + let watch_cluster_change ~__context ~host = + while !Daemon.enabled do + let m = + Cluster_client.LocalClient.UPDATES.get (rpc ~__context) + "call cluster watcher" + (Clock.Timer.span_to_s cluster_change_interval) + in + match Idl.IdM.run @@ Cluster_client.IDL.T.get m with + | Ok updates -> ( + match find_cluster_host ~__context ~host with + | Some ch -> + let cluster = Db.Cluster_host.get_cluster ~__context ~self:ch in + on_corosync_update ~__context ~cluster updates + | None -> () - | Error (InternalError message) | Error (Unix_error message) -> - warn "%s: Cannot query cluster host updates with error %s" - __FUNCTION__ message - | exception exn -> - warn - "%s: Got exception %s while query cluster host updates, retrying" - __FUNCTION__ (Printexc.to_string exn) ; - Thread.delay 3. - done - in - if Xapi_cluster_helpers.cluster_health_enabled ~__context then ( - debug "%s: create watcher for corosync-notifyd on master" __FUNCTION__ ; - ignore @@ Thread.create watch () - ) else - debug - "%s: not creating watcher for corosync-notifyd: feature cluster_health \ - not enabled" - __FUNCTION__ + ) + | Error (InternalError "UPDATES.Timeout") -> + (* UPDATES.get timed out, this is normal, now retry *) + () + | Error (InternalError message) | Error (Unix_error message) -> + warn "%s: Cannot query cluster host updates with error %s" + __FUNCTION__ message + | exception exn -> + warn "%s: Got exception %s while query cluster host updates, retrying" + __FUNCTION__ (Printexc.to_string exn) ; + Thread.delay (Clock.Timer.span_to_s cluster_change_interval) + done ; + Atomic.set cluster_change_watcher false + + (** [create_as_necessary] will create cluster watchers on the coordinator if they are not + already created. + There is no need to destroy them: once the clustering daemon is disabled, + these threads will exit as well. *) + let create_as_necessary ~__context ~host = + if Helpers.is_pool_master ~__context ~host then + if Xapi_cluster_helpers.cluster_health_enabled ~__context then + if Atomic.compare_and_set cluster_change_watcher false true then ( + debug "%s: create watcher for corosync-notifyd on coordinator" + __FUNCTION__ ; + ignore + @@ Thread.create (fun () -> watch_cluster_change ~__context ~host) () + ) else + (* someone else must have gone into the if branch above and created the thread + before us, leave it to them *) + debug + "%s: not create watcher for corosync-notifyd as it already exists" + __FUNCTION__ +end diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index ad4f35e37ed..1e03882ead1 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1040,6 +1040,8 @@ let pool_recommendations_dir = ref "/etc/xapi.pool-recommendations.d" let disable_webserver = ref false +let test_open = ref 0 + let xapi_globs_spec = [ ( "master_connection_reset_timeout" @@ -1123,6 +1125,7 @@ let xapi_globs_spec = ; ("max_spans", Int max_spans) ; ("max_traces", Int max_traces) ; ("max_observer_file_size", Int max_observer_file_size) + ; ("test-open", Int test_open) (* for consistency with xenopsd *) ] let options_of_xapi_globs_spec = diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 6450c363847..29142383a22 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-dcmi/dune b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune new file mode 100644 index 00000000000..0f438a65861 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune @@ -0,0 +1,16 @@ +(executable + (modes exe) + (name rrdp_dcmi) + (package rrdd-plugins) + (public_name xcp-rrdd-dcmi) + (libraries + dune-build-info + rrdd-plugin + rrdd-plugins.libs + xapi-idl.rrd + xapi-log + xapi-rrd + astring + ) +) + diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml new file mode 100644 index 00000000000..03afac48bc7 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml @@ -0,0 +1,80 @@ +(* + * Copyright (c) 2024 Cloud Software Group, 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. + *) + +(** Read power measurements from IPMI DCMI where available. + There is also IPMI SDR entity 21 that returns the same information (power consumption in watts), + but isn't always available, and seems to be slower to read, especially when missing. + *) + +open Rrdd_plugin + +module Process = Process (struct let name = "xcp-rrdd-dcmi" end) + +open Process + +let ipmitool_bin = "/usr/bin/ipmitool" + +let ipmitool args = + (* we connect to the local /dev/ipmi0 if available to read measurements from local BMC *) + ipmitool_bin :: "-I" :: "open" :: args |> String.concat " " + +let discover () = + Utils.exec_cmd + (module Process.D) + ~cmdstring:(ipmitool ["dcmi"; "discover"]) + ~f:(fun line -> + (* this code runs once on startup, logging all the output here will be useful for debugging *) + D.debug "DCMI discover: %s" line ; + if String.trim line = "Power management available" then + Some () + else + None + ) + +let get_dcmi_power_reading () = + Utils.exec_cmd + (module Process.D) + ~cmdstring:(ipmitool ["dcmi"; "power"; "reading"]) + ~f:(fun line -> + (* example line: ' Instantaneous power reading: 34 Watts' *) + try + Scanf.sscanf line " Instantaneous power reading : %f Watts" Option.some + with Scanf.Scan_failure _ | End_of_file -> None + ) + +let gen_dcmi_power_reading value = + ( Rrd.Host + , Ds.ds_make ~name:"DCMI-power-reading" + ~description:"Host power usage reported by IPMI DCMI" + ~value:(Rrd.VT_Float value) ~ty:Rrd.Gauge ~default:true ~units:"W" + ~min:Float.min_float ~max:65534. () + ) + +let generate_dss () = + match get_dcmi_power_reading () with + | watts :: _ -> + [gen_dcmi_power_reading watts] + | _ -> + [] + +let _ = + initialise () ; + match discover () with + | [] -> + D.info "IPMI DCMI power reading is unavailable" ; + exit 1 + | _ -> + D.info "IPMI DCMI power reading is available" ; + main_loop ~neg_shift:0.5 ~target:(Reporter.Local 1) + ~protocol:Rrd_interface.V2 ~dss_f:generate_dss diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli new file mode 100644 index 00000000000..e69de29bb2d 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/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins b/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins index 6998ad20c12..ced7c537254 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins +++ b/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins @@ -1 +1 @@ -PLUGINS="xcp-rrdd-iostat xcp-rrdd-squeezed xcp-rrdd-xenpm" +PLUGINS="xcp-rrdd-iostat xcp-rrdd-squeezed xcp-rrdd-xenpm xcp-rrdd-dcmi" diff --git a/ocaml/xcp-rrdd/test/transport/dune b/ocaml/xcp-rrdd/test/transport/dune index 0ba7d90e8eb..333b4db49ce 100644 --- a/ocaml/xcp-rrdd/test/transport/dune +++ b/ocaml/xcp-rrdd/test/transport/dune @@ -4,6 +4,7 @@ (libraries alcotest dune-build-info + fmt rrd-transport xapi-idl.rrd xapi-rrd diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index dede643723b..f72cacbbda4 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -10,6 +10,9 @@ safe-resources stunnel threads + tracing + uri + yojson xapi-backtrace xapi-cli-protocol xapi-stdext-pervasives diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 412e1c95df0..9be987f028b 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -479,14 +479,6 @@ let main_loop ifd ofd permitted_filenames = marshal_protocol ofd ; let exit_code = ref None in while !exit_code = None do - (* Wait for input asynchronously so that we can check the status - of Stunnel every now and then, for better debug/dignosis. - *) - while - match Unix.select [ifd] [] [] 5.0 with _ :: _, _, _ -> false | _ -> true - do - () - done ; let cmd = try unmarshal ifd with e -> handle_unmarshal_failure e ifd in debug "Read: %s\n%!" (string_of_message cmd) ; flush stderr ; @@ -649,7 +641,7 @@ let main_loop ifd ofd permitted_filenames = with | Unix.Unix_error (_, _, _) when !delay <= long_connection_retry_timeout -> - ignore (Unix.select [] [] [] !delay) ; + Unix.sleepf !delay ; delay := !delay *. 2. ; keep_connection () | e -> 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/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index a8b10706504..5ac6100669c 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1047,7 +1047,7 @@ let raw_console_proxy sockaddr = (fun () -> Unix.close s) with | Unix.Unix_error (_, _, _) when !delay <= long_connection_retry_timeout -> - ignore (Unix.select [] [] [] !delay) ; + Unix.sleepf !delay ; delay := !delay *. 2. ; keep_connection () | e -> 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 9f0a63e064c..6f5bce8b12f 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/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 98c88561572..2052d367585 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -128,6 +128,8 @@ let max_bytes_of_xenstore_entries entries = let vm_guest_agent_xenstore_quota_bytes = ref (25 * 1024 * 1024) +let test_open = ref 0 + let options = [ ( "queue" @@ -276,6 +278,11 @@ let options = , "Maximum size in bytes of VM xenstore-data field, and guest metrics \ copied from guest's vm-data/ and data/ xenstore tree" ) + ; ( "test-open" + , Arg.Set_int test_open + , (fun () -> string_of_int !test_open) + , "TESTING only: open N file descriptors" + ) ] let path () = Filename.concat !sockets_path "xenopsd" @@ -424,9 +431,18 @@ let log_uncaught_exception e bt = error "xenopsd exitted with an uncaught exception: %s" (Printexc.to_string e) ; log_raw_backtrace bt +let test_open () = + let count = !test_open in + if count > 0 then ( + debug "TEST: opening %d file descriptors" count ; + Xapi_stdext_unix.Unixext.test_open count ; + debug "TEST: opened %d file descriptors" count + ) + let main backend = Printexc.record_backtrace true ; Printexc.set_uncaught_exception_handler log_uncaught_exception ; + test_open () ; (* Set service name for Tracing *) Tracing_export.set_service_name "xenopsd" ; (* Listen for transferred file descriptors *) 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/domain.ml b/ocaml/xenopsd/xc/domain.ml index d116d5db835..dd3813ff6d9 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -351,7 +351,7 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept = if iommu then assert_capability CAP_DirectIO ~on_error:(fun () -> "IOMMU unavailable") ; let nested_virt = - get_platform_key ~key:"nested_virt" ~default:false require_hvm + get_platform_key ~key:"nested-virt" ~default:false require_hvm in let vpmu = get_platform_key ~key:"vpmu" ~default:false (fun _ -> Ok ()) in 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/xenopsd/xc/memory_breakdown.ml b/ocaml/xenopsd/xc/memory_breakdown.ml index 52428518dab..fae014a6ce3 100644 --- a/ocaml/xenopsd/xc/memory_breakdown.ml +++ b/ocaml/xenopsd/xc/memory_breakdown.ml @@ -242,7 +242,7 @@ let print_memory_field_values xc xs = flush stdout (** Sleeps for the given time period in seconds. *) -let sleep time_period_seconds = ignore (Unix.select [] [] [] time_period_seconds) +let sleep time_period_seconds = Unix.sleepf time_period_seconds (** Prints a header line of memory field names, and then periodically prints a line of memory field values. *) diff --git a/ocaml/xenopsd/xc/memory_summary.ml b/ocaml/xenopsd/xc/memory_summary.ml index 15ddac0098f..c63e495ccb4 100644 --- a/ocaml/xenopsd/xc/memory_summary.ml +++ b/ocaml/xenopsd/xc/memory_summary.ml @@ -36,7 +36,7 @@ let _ = let finished = ref false in while not !finished do finished := !delay < 0. ; - if !delay > 0. then ignore (Unix.select [] [] [] !delay) ; + if !delay > 0. then Unix.sleepf !delay ; flush stdout ; let physinfo = Xenctrl.physinfo xc in let one_page = 4096L in diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index 05e485a2c0a..7b4051306c7 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -4,9 +4,12 @@ (public_name xs-trace) (package xapi) (libraries + uri + tracing cmdliner tracing_export xapi-stdext-unix + zstd ) ) diff --git a/ocaml/xxhash/lib/dune b/ocaml/xxhash/lib/dune index 1923c3d6510..70b43c59192 100644 --- a/ocaml/xxhash/lib/dune +++ b/ocaml/xxhash/lib/dune @@ -15,6 +15,7 @@ (wrapped false) (libraries ctypes + ctypes.stubs integers xxhash_bindings xapi-stdext-pervasives diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index 0211fe5e9c8..6c97f499b5d 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -123,8 +123,13 @@ def with_tracecontext(self): for k, v in headers.items(): self.add_extra_header(k, v) def make_connection(self, host): + # compatibility with parent xmlrpclib.Transport HTTP/1.1 support + if self._connection and host == self._connection[0]: + return self._connection[1] + + self._connection = host, UDSHTTPConnection(host) self.with_tracecontext() - return UDSHTTPConnection(host) + return self._connection[1] def notimplemented(name, *args, **kwargs): raise NotImplementedError("XMLRPC proxies do not support python magic methods", name, *args, **kwargs) @@ -144,6 +149,11 @@ class Session(xmlrpclib.ServerProxy): def __init__(self, uri, transport=None, encoding=None, verbose=0, allow_none=1, ignore_ssl=False): + if sys.version_info[0] > 2: + # this changed to be a 'bool' in Python3 + verbose = bool(verbose) + allow_none = bool(allow_none) + # Fix for CA-172901 (+ Python 2.4 compatibility) # Fix for context=ctx ( < Python 2.7.9 compatibility) if not (sys.version_info[0] <= 2 and sys.version_info[1] <= 7 and sys.version_info[2] <= 9 ) \ @@ -159,7 +169,7 @@ def __init__(self, uri, transport=None, encoding=None, verbose=0, self._session = None self.last_login_method = None self.last_login_params = None - self.API_version = API_VERSION_1_1 + self._API_version = API_VERSION_1_1 def xenapi_request(self, methodname, params): @@ -196,24 +206,32 @@ def _login(self, method, params): self._session = result self.last_login_method = method self.last_login_params = params - self.API_version = self._get_api_version() + + # This was initialized to 1.1 in the constructor. + # Now that we are logged in, the next time API_version() is run + # it can fetch the real version. + # However nothing in this script actually needs that, so don't call it immediately. + self._API_version = None except socket.error as e: - if e.errno == socket.errno.ETIMEDOUT: + # pytype false positive: there is a socket.errno in both py2 and py3 + if e.errno == socket.errno.ETIMEDOUT: # pytype: disable=module-attr raise xmlrpclib.Fault(504, 'The connection timed out') - else: - raise e + raise e def _logout(self): try: if self.last_login_method.startswith("slave_local"): + # Proxied function, pytype can't see it + # pytype: disable=attribute-error return _parse_result(self.session.local_logout(self._session)) + # pytype: enable=attribute-error else: return _parse_result(self.session.logout(self._session)) finally: self._session = None self.last_login_method = None self.last_login_params = None - self.API_version = API_VERSION_1_1 + self._API_version = API_VERSION_1_1 def _get_api_version(self): pool = self.xenapi.pool.get_all()[0] @@ -222,15 +240,21 @@ def _get_api_version(self): minor = self.xenapi.host.get_API_version_minor(host) return "%s.%s"%(major,minor) + @property + def API_version(self): + if not self._API_version: + self._API_version = self._get_api_version() + return self._API_version + def __getattr__(self, name): if name == 'handle': return self._session elif name == 'xenapi': - return _Dispatcher(self.API_version, self.xenapi_request, None) + return _Dispatcher(self.xenapi_request, None) elif name.startswith('login') or name.startswith('slave_local'): return lambda *params: self._login(name, params) elif name == 'logout': - return _Dispatcher(self.API_version, self.xenapi_request, "logout") + return _Dispatcher(self.xenapi_request, "logout") elif name.startswith('__') and name.endswith('__'): return lambda *args, **kwargs: notimplemented(name, args, kwargs) else: @@ -261,8 +285,7 @@ def _parse_result(result): # Based upon _Method from xmlrpclib. class _Dispatcher: - def __init__(self, API_version, send, name): - self.__API_version = API_version + def __init__(self, send, name): self.__send = send self.__name = name @@ -274,9 +297,9 @@ def __repr__(self): def __getattr__(self, name): if self.__name is None: - return _Dispatcher(self.__API_version, self.__send, name) + return _Dispatcher(self.__send, name) else: - return _Dispatcher(self.__API_version, self.__send, "%s.%s" % (self.__name, name)) + return _Dispatcher(self.__send, "%s.%s" % (self.__name, name)) def __call__(self, *args): return self.__send(self.__name, args) diff --git a/scripts/xe-xentrace b/scripts/xe-xentrace index ce98e7cdf4b..94b51bcf134 100755 --- a/scripts/xe-xentrace +++ b/scripts/xe-xentrace @@ -10,10 +10,14 @@ # The VDI has the other_config:xentrace flag set to 1, so these can be # identified later on as xentrace records. # The VDI contains a ext3 fs (no partition table) and single file "trace.bz2" - +set -euo pipefail TIME=5 SIZE_GB=1 -while getopts "ht:s:" opt ; do +CIRCULAR=0 +MEMORY_MB=400 # 400 MiB +DUMP_ON_CPUAVG= + +while getopts "hct:s:M:p:r:" opt ; do case $opt in h) echo "Usage: $0 [-t time (sec)] [-s size (GB)]" @@ -23,12 +27,28 @@ while getopts "ht:s:" opt ; do ;; s) SIZE_GB=$OPTARG ;; + + c) CIRCULAR=1 + ;; + + M) MEMORY_MB=$OPTARG + ;; + + p) CIRCULAR=1 + DUMP_ON_CPUAVG=$OPTARG + REPEAT=6 + ;; + + r) REPEAT=$OPTARG + ;; + *) echo "Invalid option"; exit 1 ;; esac done -SIZE=$((${SIZE_GB} * 1024 * 1024 * 1024)) +SIZE=$((SIZE_GB * 1024 * 1024 * 1024)) +MEMORY=$((MEMORY_MB * 1024 * 1024)) if [ ! -e @INVENTORY@ ]; then echo Must run on a XAPI host. @@ -39,7 +59,7 @@ fi XE="@OPTDIR@/bin/xe" -crashdump_sr=$(${XE} host-list params=crash-dump-sr-uuid --minimal uuid=${INSTALLATION_UUID}) +crashdump_sr=$(${XE} host-list params=crash-dump-sr-uuid --minimal "uuid=${INSTALLATION_UUID}") if [ -z "${crashdump_sr}" ]; then echo No crashdump storage repository defined for the host. @@ -50,81 +70,112 @@ vdi_date=$(date +%c) vdi_name="Xentrace results at ${vdi_date}" echo -n "Creating VDI: " -vdi_uuid=$(${XE} vdi-create sr-uuid=${crashdump_sr} name-label="${vdi_name}" type=system virtual-size=${SIZE}) -echo ${vdi_uuid} - -if [ $? -ne 0 -o -z "${vdi_uuid}" ]; then +if ! vdi_uuid=$(${XE} vdi-create "sr-uuid=${crashdump_sr}" name-label="${vdi_name}" type=system "virtual-size=${SIZE}") || [ -z "${vdi_uuid}" ]; then echo error creating VDI in the crashdump storage repository exit 1 fi -${XE} vdi-param-set uuid=${vdi_uuid} other-config:xentrace=1 +echo "${vdi_uuid}" + +${XE} vdi-param-set "uuid=${vdi_uuid}" other-config:xentrace=1 mnt= function cleanup { - if [ ! -z "${vdi_uuid}" ]; then - ${XE} vdi-destroy uuid=${vdi_uuid} + killall xentrace + + if [ -n "${vdi_uuid}" ]; then + ${XE} vdi-destroy "uuid=${vdi_uuid}" fi - if [ ! -z "${mnt}" ]; then - umount ${mnt} - rmdir ${mnt} + if [ -n "${mnt}" ]; then + umount "${mnt}" + rmdir "${mnt}" fi - if [ ! -z "${vbd_uuid}" ]; then - ${XE} vbd-unplug uuid=${vbd_uuid} - ${XE} vbd-destroy uuid=${vbd_uuid} + if [ -n "${vbd_uuid}" ]; then + ${XE} vbd-unplug "uuid=${vbd_uuid}" + ${XE} vbd-destroy "uuid=${vbd_uuid}" fi } echo -n "Creating VBD: " -vbd_uuid=$(${XE} vbd-create vm-uuid=${CONTROL_DOMAIN_UUID} vdi-uuid=${vdi_uuid} device=autodetect) -echo ${vbd_uuid} - -if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then +if ! vbd_uuid=$(${XE} vbd-create "vm-uuid=${CONTROL_DOMAIN_UUID}" "vdi-uuid=${vdi_uuid}" device=autodetect) || [ -z "${vbd_uuid}" ]; then echo error creating VBD cleanup exit 1 fi +echo "${vbd_uuid}" + echo -n "Plugging VBD: " -${XE} vbd-plug uuid=${vbd_uuid} -device=/dev/$(${XE} vbd-param-get uuid=${vbd_uuid} param-name=device) +${XE} vbd-plug "uuid=${vbd_uuid}" +device=/dev/$(${XE} vbd-param-get "uuid=${vbd_uuid}" param-name=device) -if [ ! -b ${device} ]; then - echo ${device}: not a block special +if [ ! -b "${device}" ]; then + echo "${device}: not a block special" cleanup exit 1 fi -echo ${device} +echo "${device}" echo -n "Creating filesystem: " -mkfs.ext3 -j -F ${device} > /dev/null 2>&1 +mkfs.ext3 -j -F "${device}" > /dev/null 2>&1 echo "done" echo -n "Mounting filesystem: " mnt=/var/run/crashdump-${vdi_uuid} -mkdir -p ${mnt} - -mount ${device} ${mnt} +mkdir -p "${mnt}" -if [ $? -ne 0 ]; then - echo mount to ${mnt} failed +if ! mount "${device}" "${mnt}"; then + echo "mount to ${mnt} failed" cleanup exit 1 fi echo "done" +echo "Trace recording to VDI: ${vdi_uuid}" +trap cleanup EXIT + +if [ -n "${DUMP_ON_CPUAVG}" ]; then + echo "Xentrace: will dump when host cpu usage >= ${DUMP_ON_CPUAVG}" + echo "Xentrace: will dump when triggered for ${REPEAT}*5s intervals in a row" + (rrd2csv "AVERAGE:host:${INSTALLATION_UUID}:cpu_avg" \ + | (TRIGGER=0 + read -r _IGNORE + while IFS=, read -r _time value; do + if (( $(echo "${value} > ${DUMP_ON_CPUAVG}/100" | bc -l) )); then + TRIGGER=$((TRIGGER + 1)) + else + TRIGGER=0 + fi + if [ "${TRIGGER}" -gt "${REPEAT}" ]; then + TRIGGER=0 + echo "Killing xentrace to dump trace" + killall xentrace || true + echo "Waiting for 1m" + sleep 60 + fi + done))& +fi -echo "Xentrace: starting" -/usr/bin/xentrace -D -e all -r 1 ${mnt}/trace -T ${TIME} +while : ; do + echo "Xentrace: starting" + TRACE="${mnt}/trace.$(date +%s)" + if [ "${CIRCULAR}" = 1 ]; then + echo "Xentrace: in circular mode, waiting for 'killall xentrace'" + /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -M "${MEMORY}" + else + /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -T "${TIME}" + fi -echo "Xentrace: compressing" -bzip2 -9 ${mnt}/trace + # do not destroy the VDI anymore, we've got useful data on it + vdi_uuid="" -echo "Xentrace: done" -echo "Trace recorded to VDI: ${vdi_uuid}" + echo "Xentrace: compressing ${TRACE}" + bzip2 -9 "${TRACE}" -vdi_uuid="" -cleanup + [ "${CIRCULAR}" = 1 ] || break +done + +echo "Xentrace: done" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 58e6fd0509e..4adef00e43e 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -12,6 +12,8 @@ depends: [ "base-unix" "odoc" {with-doc} "xapi-stdext-pervasives" {= version} + "mtime" {with-test} + "xapi-stdext-unix" {= version} ] build: [ ["dune" "subst"] {dev} diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index a20dfbb34e0..e154fe829da 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -9,12 +9,19 @@ bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.0"} "ocaml" {>= "4.12.0"} + "alcotest" {with-test} "base-unix" + "bisect_ppx" {with-test} "fd-send-recv" {>= "2.0.0"} + "fmt" + "mtime" {>= "2.0.0" & with-test} + "logs" {with-test} + "qcheck-core" {>= "0.21.2" & with-test} "odoc" {with-doc} "xapi-backtrace" "unix-errno" "xapi-stdext-pervasives" {= version} + "polly" ] build: [ ["dune" "subst"] {dev} @@ -32,4 +39,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" ]