diff --git a/clock.opam b/clock.opam index 44c24235c58..45b4fd162c2 100644 --- a/clock.opam +++ b/clock.opam @@ -7,12 +7,14 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.12"} "alcotest" {with-test} "astring" "mtime" "ptime" + "qcheck-core" {with-test} + "qcheck-alcotest" {with-test} "odoc" {with-doc} ] build: [ diff --git a/dune b/dune index e2b4842adb5..9cf03f02dfc 100644 --- a/dune +++ b/dune @@ -3,7 +3,7 @@ (ocamlopt_flags (:standard -g -p -w -39)) (flags (:standard -w -39)) ) - (dev (flags (:standard -g -w -39))) + (dev (flags (:standard -g -w -39 -warn-error -69))) (release (flags (:standard -w -39-6@5)) (env-vars (ALCOTEST_COMPACT 1)) diff --git a/dune-project b/dune-project index 6d0c661ee31..20a8079ca44 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,5 @@ -(lang dune 3.0) +(lang dune 3.15) + (formatting (enabled_for ocaml)) (using menhir 2.0) @@ -28,6 +29,8 @@ astring mtime ptime + (qcheck-core :with-test) + (qcheck-alcotest :with-test) ) ) @@ -66,7 +69,6 @@ (synopsis "Xen-API client library for remotely-controlling a xapi host") (authors "David Scott" "Anil Madhavapeddy" "Jerome Maloberti" "John Else" "Jon Ludlam" "Thomas Sanders" "Mike McClurg") (depends - dune-build-info (alcotest :with-test) astring (cohttp (>= "0.22.0")) @@ -187,7 +189,6 @@ (description "This daemon monitors 'datasources' i.e. time-varying values such as performance counters and records the samples in RRD archives. These archives can be used to examine historical performance trends.") (depends (ocaml (>= "4.02.0")) - dune-build-info (alcotest :with-test) astring (gzip (= :version)) @@ -300,6 +301,68 @@ (package (name xapi) + (synopsis "The toolstack daemon which implements the XenAPI") + (description "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.") + (depends + alcotest ; needed for the quicktest binary + angstrom + base-threads + base64 + cdrom + conf-pam + (crowbar :with-test) + ctypes + ctypes-foreign + domain-name + (ezxenstore (= :version)) + (fmt :with-test) + hex + (http-lib (and :with-test (= :version))) ; the public library is only used for testing + ipaddr + mirage-crypto + mirage-crypto-pk + (mirage-crypto-rng (>= "0.11.0")) + (message-switch-unix (= :version)) + mtime + opentelemetry-client-ocurl + pci + (pciutil (= :version)) + ppx_deriving_rpc + ppx_sexp_conv + ppx_deriving + psq + rpclib + (rrdd-plugin (= :version)) + rresult + sexpr + sha + (stunnel (= :version)) + tar + tar-unix + (uuid (= :version)) + x509 + (xapi-client (= :version)) + (xapi-cli-protocol (= :version)) + (xapi-consts (= :version)) + (xapi-datamodel (= :version)) + (xapi-expiry-alerts (= :version)) + (xapi-idl (= :version)) + (xapi-inventory (= :version)) + (xapi-log (= :version)) + (xapi-stdext-date (= :version)) + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std (= :version)) + (xapi-stdext-threads (= :version)) + (xapi-stdext-unix (= :version)) + (xapi-stdext-zerocheck (= :version)) + (xapi-test-utils :with-test) + (xapi-tracing (= :version)) + (xapi-types (= :version)) + (xapi-xenopsd (= :version)) + (xml-light2 (= :version)) + yojson + (zstd (= :version)) + ) ) (package @@ -321,6 +384,32 @@ (package (name vhd-tool) + (synopsis "Manipulate .vhd files") + (tags ("org.mirage" "org:xapi-project")) + (depends + (alcotest-lwt :with-test) + cohttp-lwt + conf-libssl + (cstruct (>= "3.0.0")) + (ezxenstore (= :version)) + (forkexec (= :version)) + io-page + lwt + nbd-unix + ppx_cstruct + ppx_deriving_rpc + re + rpclib + sha + tar + (vhd-format (= :version)) + (vhd-format-lwt (= :version)) + (xapi-idl (= :version)) + (xapi-log (= :version)) + (xen-api-client-lwt (= :version)) + xenstore + xenstore_transport + ) ) (package @@ -438,6 +527,16 @@ This package provides an Lwt compatible interface to the library.") (package (name message-switch-unix) + (synopsis "A simple store-and-forward message switch") + (description "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages.") + (depends + base-threads + cohttp + (message-switch-core (= :version)) + ppx_deriving_rpc + rpclib + (xapi-stdext-threads (= :version)) + ) ) (package diff --git a/forkexec.opam b/forkexec.opam index 3aea97441c2..6d6d2504488 100644 --- a/forkexec.opam +++ b/forkexec.opam @@ -8,7 +8,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "base-threads" "fd-send-recv" {>= "2.0.0"} "ppx_deriving_rpc" diff --git a/http-lib.opam b/http-lib.opam index 77965984777..e8a5de4ddc9 100644 --- a/http-lib.opam +++ b/http-lib.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "base64" {>= "3.1.0"} diff --git a/message-switch-core.opam b/message-switch-core.opam index 2d671053b9b..2fd00d31457 100644 --- a/message-switch-core.opam +++ b/message-switch-core.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "astring" "cohttp" {>= "0.21.1"} "ppx_deriving_rpc" diff --git a/message-switch-unix.opam b/message-switch-unix.opam index 64fd72db241..c9379979e2d 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.opam @@ -1,29 +1,35 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -name: "message-switch-unix" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "A simple store-and-forward message switch" +description: + "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] -build: [ - ["./configure" "--prefix" "%{prefix}%"] - [ "dune" "build" "-p" name "-j" jobs ] -] depends: [ - "ocaml" - "dune" {build & >= "1.4"} - "odoc" {with-doc} + "dune" {>= "3.15"} "base-threads" - "message-switch-core" + "cohttp" + "message-switch-core" {= version} "ppx_deriving_rpc" + "rpclib" + "xapi-stdext-threads" {= version} + "odoc" {with-doc} ] -synopsis: "A simple store-and-forward message switch" -description: """ -The switch stores messages in queues with well-known names. Clients use -a simple HTTP protocol to enqueue and dequeue messages.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/message-switch-unix.opam.template b/message-switch-unix.opam.template deleted file mode 100644 index f21bd6e1883..00000000000 --- a/message-switch-unix.opam.template +++ /dev/null @@ -1,27 +0,0 @@ -opam-version: "2.0" -name: "message-switch-unix" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] -build: [ - ["./configure" "--prefix" "%{prefix}%"] - [ "dune" "build" "-p" name "-j" jobs ] -] -depends: [ - "ocaml" - "dune" {build & >= "1.4"} - "odoc" {with-doc} - "base-threads" - "message-switch-core" - "ppx_deriving_rpc" -] -synopsis: "A simple store-and-forward message switch" -description: """ -The switch stores messages in queues with well-known names. Clients use -a simple HTTP protocol to enqueue and dequeue messages.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/message-switch.opam b/message-switch.opam index 39cf5bea18a..b09cec4ca7c 100644 --- a/message-switch.opam +++ b/message-switch.opam @@ -31,6 +31,7 @@ depends: [ "ppx_sexp_conv" "sexplib" "shared-block-ring" {>= "2.3.0"} + "xapi-stdext-unix" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/message-switch.opam.template b/message-switch.opam.template index 5322fe9f419..793c8aceaa5 100644 --- a/message-switch.opam.template +++ b/message-switch.opam.template @@ -29,6 +29,7 @@ depends: [ "ppx_sexp_conv" "sexplib" "shared-block-ring" {>= "2.3.0"} + "xapi-stdext-unix" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/ocaml/alerts/certificate/dune b/ocaml/alerts/certificate/dune index d3743285e77..137b23d265e 100644 --- a/ocaml/alerts/certificate/dune +++ b/ocaml/alerts/certificate/dune @@ -1,6 +1,7 @@ (library (name certificate_check) (modules certificate_check) + (modes best) (libraries astring xapi-expiry-alerts @@ -19,7 +20,7 @@ (modules certificate_check_main) (libraries certificate_check - dune-build-info + http_lib xapi-client xapi-types diff --git a/ocaml/alerts/dune b/ocaml/alerts/dune index 4e6205891e7..9396600b2b5 100644 --- a/ocaml/alerts/dune +++ b/ocaml/alerts/dune @@ -2,9 +2,7 @@ (name expiry_alert) (public_name xapi-expiry-alerts) (libraries - astring xapi-client - xapi-consts xapi-types xapi-stdext-date ) diff --git a/ocaml/auth/dune b/ocaml/auth/dune index f963fbb591b..d132a37b068 100644 --- a/ocaml/auth/dune +++ b/ocaml/auth/dune @@ -1,4 +1,5 @@ (library + (modes best) (foreign_stubs (language c) (names xa_auth xa_auth_stubs) diff --git a/ocaml/database/dune b/ocaml/database/dune index 08108ad6c55..14ac44931bd 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -9,14 +9,12 @@ db_names db_exn schema string_marshall_helper string_unmarshall_helper test_schemas) (libraries - ppx_sexp_conv.runtime-lib - sexplib0 sexpr xapi-log xapi-stdext-encodings ) (wrapped false) - (preprocess (pps ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_sexp_conv) Schema))) ) (library @@ -50,7 +48,10 @@ xml-light2 xmlm ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess + (per_module + ((pps ppx_deriving_rpc) + Db_cache_types Db_filter_types Db_rpc_common_v2 Db_secret_string))) ) (executable @@ -60,7 +61,7 @@ (package xapi) (modules block_device_io) (libraries - dune-build-info + xapi_database xapi-log xapi-stdext-pervasives @@ -74,7 +75,7 @@ (modes exe) (modules database_server_main) (libraries - dune-build-info + http_lib httpsvr threads.posix @@ -90,10 +91,8 @@ (package xapi) (modules db_cache_test unit_test_marshall) (libraries - alcotest - dune-build-info + alcotest http_lib - ppx_sexp_conv.runtime-lib rpclib.xml sexplib sexplib0 @@ -112,7 +111,6 @@ ) (libraries alcotest - dune-build-info xapi_database xml-light2 ) diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index 2547ae53182..346773303e8 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -71,7 +71,7 @@ let force_connection_reset () = host and port are fixed values. *) let rec purge_stunnels verify_cert = match - Stunnel_cache.with_remove ~host ~port verify_cert @@ fun st -> + Stunnel_cache.with_remove ~host ~port @@ fun st -> try Stunnel.disconnect ~wait:false ~force:true st with _ -> () with | None -> diff --git a/ocaml/db_process/dune b/ocaml/db_process/dune index 238f24263d8..bbe92d2b944 100644 --- a/ocaml/db_process/dune +++ b/ocaml/db_process/dune @@ -4,7 +4,7 @@ (public_name xapi-db-process) (package xapi) (libraries - dune-build-info + unix xapi-inventory xapi_database diff --git a/ocaml/doc/dune b/ocaml/doc/dune index 360f0a1a5d7..ee0f921d032 100644 --- a/ocaml/doc/dune +++ b/ocaml/doc/dune @@ -1,9 +1,7 @@ (executable (modes exe) (name jsapi) - (libraries - dune-build-info - gzip + (libraries mustache rpclib.core rpclib.json diff --git a/ocaml/events/dune b/ocaml/events/dune index 0a816adc6b2..bb2b0420399 100644 --- a/ocaml/events/dune +++ b/ocaml/events/dune @@ -4,7 +4,6 @@ (public_name event_listen) (package xapi) (libraries - dune-build-info http_lib xapi-client xapi-types diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 160f444dd34..749f173b977 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -15,5 +15,4 @@ xapi-stdext-unix xapi-tracing ) - (preprocess - (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Fe)))) diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml index ef4ad887f31..e800e8bf95f 100644 --- a/ocaml/forkexecd/src/child.ml +++ b/ocaml/forkexecd/src/child.ml @@ -94,14 +94,7 @@ let handle_comms comms_sock fd_sock state = let log_failure args child_pid reason = (* The commandline might be too long to clip it *) let cmdline = String.concat " " args in - let limit = 80 - 3 in - let cmdline' = - if String.length cmdline > limit then - String.sub cmdline 0 limit ^ "..." - else - cmdline - in - Fe_debug.error "%d (%s) %s" child_pid cmdline' reason + Fe_debug.error "%d (%s) %s" child_pid cmdline reason let report_child_exit comms_sock args child_pid status = let module Unixext = Xapi_stdext_unix.Unixext in diff --git a/ocaml/gencert/dune b/ocaml/gencert/dune index fedcfefc04e..ef7875abd29 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -2,6 +2,7 @@ (name gencertlib) (wrapped true) (modules lib selfcert pem) + (modes best) (libraries angstrom astring @@ -9,6 +10,7 @@ forkexec mirage-crypto mirage-crypto-pk + mirage-crypto-rng mirage-crypto-rng.unix ptime ptime.clock.os @@ -31,7 +33,6 @@ (modules gencert) (libraries astring - dune-build-info gencertlib x509 xapi-inventory @@ -48,11 +49,11 @@ (libraries alcotest cstruct - dune-build-info fmt gencertlib mirage-crypto mirage-crypto-pk + mirage-crypto-rng mirage-crypto-rng.unix ptime result diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index 7eb41411102..970954a5371 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -19,8 +19,6 @@ open Rresult type t_certificate = Leaf | Chain -let () = Mirage_crypto_rng_unix.initialize () - let validate_private_key pkcs8_private_key = let ensure_rsa_key_length = function | `RSA priv -> diff --git a/ocaml/gencert/selfcert.ml b/ocaml/gencert/selfcert.ml index 02749493f95..3b022bcb19f 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -41,9 +41,9 @@ let valid_from' date = | None, false -> Ptime_clock.now () -(** initialize the random number generator at program startup when this -module is loaded. *) -let () = Mirage_crypto_rng_unix.initialize () +(* Needed to initialize the rng to create random serial codes when signing + certificates *) +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) (** [write_cert] writes a PKCS12 file to [path]. The typical file extension would be ".pem". It attempts to do that atomically by @@ -158,7 +158,7 @@ let host ~name ~dns_names ~ips ?valid_from ~valid_for_days pemfile cert_gid = in R.failwith_error_msg res -let serial_stamp () = Unix.gettimeofday () |> string_of_float +let serial_stamp () = Ptime_clock.now () |> Ptime.to_float_s |> string_of_float let xapi_pool ?valid_from ~valid_for_days ~uuid pemfile cert_gid = let valid_from = valid_from' valid_from in diff --git a/ocaml/gencert/test_lib.ml b/ocaml/gencert/test_lib.ml index fddee2ad41c..f3a54517ad4 100644 --- a/ocaml/gencert/test_lib.ml +++ b/ocaml/gencert/test_lib.ml @@ -8,7 +8,7 @@ open Rresult.R.Infix let ( let* ) = Rresult.R.bind (* Initialize RNG for testing certificates *) -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let time_of_rfc3339 date = match Ptime.of_rfc3339 date with diff --git a/ocaml/idl/autogen/dune b/ocaml/idl/autogen/dune index 483a0dbdef8..a423ff4a937 100644 --- a/ocaml/idl/autogen/dune +++ b/ocaml/idl/autogen/dune @@ -3,4 +3,4 @@ (deps (source_tree .) ) -) \ No newline at end of file +) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 089986a5625..bfb6ce0cf2c 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -28,9 +28,9 @@ let prototyped_of_field = function | "Repository", "gpgkey_path" -> Some "22.12.0" | "Certificate", "fingerprint_sha1" -> - Some "24.19.1-next" + Some "24.20.0" | "Certificate", "fingerprint_sha256" -> - Some "24.19.1-next" + Some "24.20.0" | "Cluster_host", "last_update_live" -> Some "24.3.0" | "Cluster_host", "live" -> diff --git a/ocaml/idl/datamodel_values.ml b/ocaml/idl/datamodel_values.ml index a13330f971d..1b463d4b2e7 100644 --- a/ocaml/idl/datamodel_values.ml +++ b/ocaml/idl/datamodel_values.ml @@ -80,7 +80,7 @@ let to_ocaml_string v = in aux (to_rpc v) -let rec to_db v = +let to_db v = let open Schema.Value in match v with | VString s -> diff --git a/ocaml/idl/dune b/ocaml/idl/dune index 837c3b0013a..430938311f8 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -8,7 +8,6 @@ datamodel_diagnostics datamodel_repository datamodel_lifecycle datamodel_vtpm datamodel_observer datamodel_vm_group) (libraries - ppx_sexp_conv.runtime-lib rpclib.core sexplib0 sexpr @@ -18,10 +17,9 @@ xapi-schema xapi-stdext-date xapi-stdext-std - xapi-stdext-unix ) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Datamodel_types))) ) (executable @@ -29,7 +27,6 @@ (name datamodel_main) (modules datamodel_main dot_backend dtd_backend markdown_backend) (libraries - dune-build-info mustache xapi-datamodel xapi-stdext-std @@ -53,7 +50,6 @@ (modes exe) (modules schematest) (libraries - dune-build-info rpclib.core rpclib.json xapi_datamodel @@ -67,8 +63,7 @@ (public_name gen_lifecycle) (package xapi-datamodel) (modules gen_lifecycle) - (libraries - dune-build-info + (libraries xapi-datamodel xapi-consts.xapi_version ) diff --git a/ocaml/idl/json_backend/dune b/ocaml/idl/json_backend/dune index 804453c59c1..c03bead0cd8 100644 --- a/ocaml/idl/json_backend/dune +++ b/ocaml/idl/json_backend/dune @@ -1,8 +1,7 @@ (executable (modes exe) (name gen_json) - (libraries - dune-build-info + (libraries fmt xapi-datamodel xapi-consts diff --git a/ocaml/idl/ocaml_backend/dune b/ocaml/idl/ocaml_backend/dune index e373fe33d09..f6c4173d363 100644 --- a/ocaml/idl/ocaml_backend/dune +++ b/ocaml/idl/ocaml_backend/dune @@ -1,15 +1,12 @@ (executable - (modes exe) + (modes byte) (name gen_api_main) (libraries astring - dune-build-info - sexpr - uuid + uuidm xapi-consts xapi-datamodel xapi-log - xapi-stdext-pervasives xapi-stdext-std ) ) diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 31011eec08d..564121ab819 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -412,7 +412,6 @@ let gen_client_types highapi = ; gen_record_type ~with_module:true highapi (toposort_types highapi all_types) ; gen_enum_helpers all_types - ; O.Signature.strings_of (Gen_client.gen_signature highapi) ] ) diff --git a/ocaml/idl/ocaml_backend/gen_rbac.ml b/ocaml/idl/ocaml_backend/gen_rbac.ml index 5f34ace5a46..64f8f4200ef 100644 --- a/ocaml/idl/ocaml_backend/gen_rbac.ml +++ b/ocaml/idl/ocaml_backend/gen_rbac.ml @@ -57,7 +57,7 @@ let writer_csv static_permissions_roles = let hash2uuid str = let h = Digest.string str in - Option.map Uuidx.to_string (Uuidx.of_bytes h) + Option.map Uuidm.to_string (Uuidm.of_bytes h) let replace_char str c1 c2 = let buf = Bytes.of_string str in diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 3276c2c08ff..67fbef3208f 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -3,7 +3,6 @@ (public_name clock) (modules date timer) (libraries - astring fmt (re_export mtime) mtime.clock.os @@ -12,9 +11,23 @@ ) ) +(library + (name test_timer) + (package clock) + (modules test_timer) + (libraries + alcotest + clock + fmt + mtime.clock.os + qcheck-alcotest + qcheck-core + ) +) + (tests - (names test_date test_timer) + (names test_date test_timer_run) (package clock) - (modules test_date test_timer) - (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-core.runner) + (modules test_date test_timer_run) + (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-alcotest test_timer) ) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml index 2d5e20d7d8a..3729826cfa3 100644 --- a/ocaml/libs/clock/test_timer.ml +++ b/ocaml/libs/clock/test_timer.ml @@ -2,82 +2,6 @@ module Timer = Clock.Timer module Gen = QCheck2.Gen module Test = QCheck2.Test -module QCheck_alcotest = struct - (* SPDX: BSD-2-Clause - From github.com/c-cube/qcheck - *) - - module Q = QCheck2 - module T = QCheck2.Test - module Raw = QCheck_base_runner.Raw - - let seed_ = - lazy - (let s = - try int_of_string @@ Sys.getenv "QCHECK_SEED" - with _ -> Random.self_init () ; Random.int 1_000_000_000 - in - Printf.printf "qcheck random seed: %d\n%!" s ; - s - ) - - let default_rand () = - (* random seed, for repeatability of tests *) - Random.State.make [|Lazy.force seed_|] - - let verbose_ = - lazy - ( match Sys.getenv "QCHECK_VERBOSE" with - | "1" | "true" -> - true - | _ -> - false - | exception Not_found -> - false - ) - - let long_ = - lazy - ( match Sys.getenv "QCHECK_LONG" with - | "1" | "true" -> - true - | _ -> - false - | exception Not_found -> - false - ) - - let to_alcotest ?(colors = false) ?(verbose = Lazy.force verbose_) - ?(long = Lazy.force long_) ?(debug_shrink = None) ?debug_shrink_list - ?(rand = default_rand ()) (t : T.t) = - let (T.Test cell) = t in - let handler name cell r = - match (r, debug_shrink) with - | QCheck2.Test.Shrunk (step, x), Some out -> - let go = - match debug_shrink_list with - | None -> - true - | Some test_list -> - List.mem name test_list - in - if not go then - () - else - QCheck_base_runner.debug_shrinking_choices ~colors ~out ~name cell - ~step x - | _ -> - () - in - let print = Raw.print_std in - let name = T.get_name cell in - let run () = - let call = Raw.callback ~colors ~verbose ~print_res:true ~print in - T.check_cell_exn ~long ~call ~handler ~rand cell - in - ((name, `Slow, run) : unit Alcotest.test_case) -end - let spans = Gen.oneofa ([|1; 100; 300|] |> Array.map (fun v -> Mtime.Span.(v * ms))) @@ -136,8 +60,6 @@ let test_timer_remaining = Mtime.Span.pp duration Timer.pp timer ; true -let tests_timer = List.map QCheck_alcotest.to_alcotest [test_timer_remaining] - let combinations = let pair x y = (x, y) in let rec loop acc = function @@ -230,4 +152,4 @@ let test_conversion_from_s = let tests_span = List.concat [test_conversion_to_s; test_conversion_from_s; test_span_compare] -let () = Alcotest.run "Timer" [("Timer", tests_timer); ("Span", tests_span)] +let tests = [test_timer_remaining] diff --git a/ocaml/libs/clock/test_timer.mli b/ocaml/libs/clock/test_timer.mli index e69de29bb2d..510dfaf2bdc 100644 --- a/ocaml/libs/clock/test_timer.mli +++ b/ocaml/libs/clock/test_timer.mli @@ -0,0 +1,3 @@ +val tests_span : unit Alcotest.V1.test_case list + +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/clock/test_timer_run.ml b/ocaml/libs/clock/test_timer_run.ml new file mode 100644 index 00000000000..0bf62436fe6 --- /dev/null +++ b/ocaml/libs/clock/test_timer_run.ml @@ -0,0 +1,4 @@ +let tests_timer = List.map QCheck_alcotest.to_alcotest Test_timer.tests + +let () = + Alcotest.run "Timer" [("Timer", tests_timer); ("Span", Test_timer.tests_span)] diff --git a/ocaml/libs/clock/test_timer_run.mli b/ocaml/libs/clock/test_timer_run.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/http-lib/buf_io.ml b/ocaml/libs/http-lib/buf_io.ml index 6a6397a614c..7073cf76a05 100644 --- a/ocaml/libs/http-lib/buf_io.ml +++ b/ocaml/libs/http-lib/buf_io.ml @@ -13,12 +13,7 @@ *) (* Buffered IO with timeouts *) -type t = { - fd: Unix.file_descr - ; mutable buf: bytes - ; mutable cur: int - ; mutable max: int -} +type t = {fd: Unix.file_descr; buf: bytes; mutable cur: int; mutable max: int} type err = | (* Line input is > 1024 chars *) diff --git a/ocaml/libs/http-lib/bufio_test.ml b/ocaml/libs/http-lib/bufio_test.ml index 7937adc73ea..81aac2ad879 100644 --- a/ocaml/libs/http-lib/bufio_test.ml +++ b/ocaml/libs/http-lib/bufio_test.ml @@ -98,7 +98,9 @@ let test_buf_io = in true +let tests = [test_buf_io] + 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 index e69de29bb2d..a10acd45016 100644 --- a/ocaml/libs/http-lib/bufio_test.mli +++ b/ocaml/libs/http-lib/bufio_test.mli @@ -0,0 +1 @@ +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/http-lib/bufio_test_run.ml b/ocaml/libs/http-lib/bufio_test_run.ml new file mode 100644 index 00000000000..a7a1cacab7e --- /dev/null +++ b/ocaml/libs/http-lib/bufio_test_run.ml @@ -0,0 +1 @@ +let () = QCheck_base_runner.run_tests_main Bufio_test.tests diff --git a/ocaml/libs/http-lib/bufio_test_run.mli b/ocaml/libs/http-lib/bufio_test_run.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index ee510d7fc42..5cc1f8292e0 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -3,7 +3,7 @@ (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 bufio_test)) + (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test bufio_test_run)) (preprocess (per_module ((pps ppx_deriving_rpc) Http))) (libraries astring @@ -60,16 +60,28 @@ (modules http_test radix_tree_test) (libraries alcotest - dune-build-info + fmt http_lib ) ) (test - (name bufio_test) + (name bufio_test_run) (package http-lib) (modes (best exe)) + (modules bufio_test_run) + (libraries + qcheck-core.runner + bufio_test + ) + ; use fixed seed to avoid causing random failures in CI and package builds + (action (run %{test} -v -bt --seed 42)) +) + +(library + (name bufio_test) + (modes best) (modules bufio_test) (libraries fmt @@ -79,11 +91,8 @@ 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 @@ -97,7 +106,7 @@ (name test_client) (modules test_client) (libraries - dune-build-info + http_lib safe-resources stunnel @@ -112,7 +121,7 @@ (name test_server) (modules test_server) (libraries - dune-build-info + http_lib httpsvr safe-resources diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c6ff41be709..09dc4a66ed4 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -94,6 +94,13 @@ let http_501_method_not_implemented ?(version = "1.0") () = ; "Cache-Control: no-cache, no-store" ] +let http_503_service_unavailable ?(version = "1.0") () = + [ + Printf.sprintf "HTTP/%s 503 Service Unavailable" version + ; "Connection: close" + ; "Cache-Control: no-cache, no-store" + ] + module Hdr = struct let task_id = "task-id" diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 687c4d2f8c7..384367e2463 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -189,6 +189,8 @@ val http_500_internal_server_error : ?version:string -> unit -> string list val http_501_method_not_implemented : ?version:string -> unit -> string list +val http_503_service_unavailable : ?version:string -> unit -> string list + module Hdr : sig val task_id : string (** Header used for task id *) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index d8718bd68a6..26ad35f712f 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -41,6 +41,8 @@ open D module E = Debug.Make (struct let name = "http_internal_errors" end) +let ( let* ) = Option.bind + type uri_path = string module Stats = struct @@ -296,10 +298,7 @@ module Server = struct let add_handler x ty uri handler = let existing = - if MethodMap.mem ty x.handlers then - MethodMap.find ty x.handlers - else - Radix_tree.empty + Option.value (MethodMap.find_opt ty x.handlers) ~default:Radix_tree.empty in x.handlers <- MethodMap.add ty @@ -307,11 +306,9 @@ module Server = struct x.handlers let find_stats x m uri = - if not (MethodMap.mem m x.handlers) then - None - else - let rt = MethodMap.find m x.handlers in - Option.map (fun te -> te.TE.stats) (Radix_tree.longest_prefix uri rt) + let* rt = MethodMap.find_opt m x.handlers in + let* te = Radix_tree.longest_prefix uri rt in + Some te.TE.stats let all_stats x = let open Radix_tree in diff --git a/ocaml/libs/http-lib/xmlrpc_client.ml b/ocaml/libs/http-lib/xmlrpc_client.ml index bdfc63621df..a93bda5e888 100644 --- a/ocaml/libs/http-lib/xmlrpc_client.ml +++ b/ocaml/libs/http-lib/xmlrpc_client.ml @@ -189,7 +189,7 @@ let with_reusable_stunnel ?use_fork_exec_helper ?write_to_log ?verify_cert host (* 1. First check if there is a suitable stunnel in the cache. *) let rec loop () = match - Stunnel_cache.with_remove ~host ~port verify_cert @@ fun x -> + Stunnel_cache.with_remove ~host ~port @@ fun x -> if check_reusable x.Stunnel.fd (Stunnel.getpid x.Stunnel.pid) then Ok (f x) else ( diff --git a/ocaml/libs/log/dune b/ocaml/libs/log/dune index fdfd739d082..42e5f664119 100644 --- a/ocaml/libs/log/dune +++ b/ocaml/libs/log/dune @@ -11,7 +11,6 @@ logs threads.posix xapi-backtrace - xapi-stdext-pervasives ) (wrapped false) ) diff --git a/ocaml/libs/sexpr/dune b/ocaml/libs/sexpr/dune index 8f1c2a0e0ef..77653c2abcc 100644 --- a/ocaml/libs/sexpr/dune +++ b/ocaml/libs/sexpr/dune @@ -9,8 +9,6 @@ (modules (:standard \ sexprpp)) (libraries astring - threads.posix - xapi-stdext-threads ) ) diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index 36d986b89c3..d69fbf10091 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -37,11 +37,7 @@ let ignore_log fmt = Printf.ksprintf (fun _ -> ()) fmt (* Use and overlay the definition from D. *) let debug = if debug_enabled then debug else ignore_log -type endpoint = { - host: string - ; port: int - ; verified: Stunnel.verification_config option -} +type endpoint = {host: string; port: int} (* Need to limit the absolute number of stunnels as well as the maximum age *) let max_stunnel = 70 @@ -187,13 +183,7 @@ let add (x : Stunnel.t) = incr counter ; Hashtbl.add !times idx now ; Tbl.move_into !stunnels idx x ; - let ep = - { - host= x.Stunnel.host - ; port= x.Stunnel.port - ; verified= x.Stunnel.verified - } - in + let ep = {host= x.Stunnel.host; port= x.Stunnel.port} in let existing = Option.value (Hashtbl.find_opt !index ep) ~default:[] in Hashtbl.replace !index ep (idx :: existing) ; debug "Adding stunnel id %s (idle %.2f) to the cache" (id_of_stunnel x) 0. ; @@ -203,8 +193,8 @@ let add (x : Stunnel.t) = (** Returns an Stunnel.t for this endpoint (oldest first), raising Not_found if none can be found. First performs a garbage-collection, which discards expired stunnels if needed. *) -let with_remove ~host ~port verified f = - let ep = {host; port; verified} in +let with_remove ~host ~port f = + let ep = {host; port} in let get_id () = with_lock m (fun () -> unlocked_gc () ; @@ -253,7 +243,7 @@ let flush () = let with_connect ?use_fork_exec_helper ?write_to_log ~verify_cert ~host ~port f = - match with_remove ~host ~port verify_cert f with + match with_remove ~host ~port f with | Some r -> r | None -> diff --git a/ocaml/libs/stunnel/stunnel_cache.mli b/ocaml/libs/stunnel/stunnel_cache.mli index 00f4ce9df62..9a2923dfcbf 100644 --- a/ocaml/libs/stunnel/stunnel_cache.mli +++ b/ocaml/libs/stunnel/stunnel_cache.mli @@ -28,7 +28,7 @@ val with_connect : -> (Stunnel.t -> 'b) -> 'b (** Connects via stunnel (optionally via an external 'fork/exec helper') to - a host and port. If there is a suitable stunnel in the cache then this + a host and port. If there is a suitable stunnel in the cache then this will be used, otherwise we make a fresh one. *) val add : Stunnel.t -> unit @@ -37,7 +37,6 @@ val add : Stunnel.t -> unit val with_remove : host:string (** host *) -> port:int (** port *) - -> Stunnel.verification_config option -> (Stunnel.t -> 'b) -> 'b option (** Given a host and port call a function with a cached stunnel, or return None. *) diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index a361a4fde3a..6109c8aa713 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -1607,8 +1607,6 @@ module Vhd = struct module Field = struct (** Dynamically-typed field-level access *) - type 'a f = {name: string; get: 'a t -> string} - let _features = "features" let _data_offset = "data-offset" @@ -1770,8 +1768,6 @@ module Vhd = struct opt (fun (t, _) -> Int32.to_string t.Batmap_header.checksum) t.batmap else None - - type 'a t = 'a f end end diff --git a/ocaml/libs/vhd/vhd_format_lwt/block.ml b/ocaml/libs/vhd/vhd_format_lwt/block.ml index 1ab35d33585..b4574e14e28 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/block.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/block.ml @@ -25,7 +25,7 @@ let pp_write_error = Mirage_block.pp_write_error type info = Mirage_block.info -type t = {mutable vhd: IO.fd Vhd_format.F.Vhd.t option; info: info; id: string} +type t = {mutable vhd: IO.fd Vhd_format.F.Vhd.t option; info: info} let connect path = Lwt_unix.LargeFile.stat path >>= fun _ -> @@ -38,8 +38,7 @@ let connect path = let sector_size = 512 in let size_sectors = Int64.div vhd.Vhd.footer.Footer.current_size 512L in let info = Mirage_block.{read_write; sector_size; size_sectors} in - let id = path in - return {vhd= Some vhd; info; id} + return {vhd= Some vhd; info} let disconnect t = match t.vhd with diff --git a/ocaml/libs/vhd/vhd_format_lwt/iO.ml b/ocaml/libs/vhd/vhd_format_lwt/iO.ml index 0940e6c56c3..d2768374795 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/iO.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/iO.ml @@ -46,13 +46,13 @@ let complete name offset op fd buffer = module Fd = struct open Lwt - type fd = {fd: Lwt_unix.file_descr; filename: string; lock: Lwt_mutex.t} + type fd = {fd: Lwt_unix.file_descr; lock: Lwt_mutex.t} let openfile filename rw = let unix_fd = File.openfile filename rw 0o644 in let fd = Lwt_unix.of_unix_file_descr unix_fd in let lock = Lwt_mutex.create () in - return {fd; filename; lock} + return {fd; lock} let fsync {fd; _} = let fd' = Lwt_unix.unix_file_descr fd in 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 ef30cfb5ba4..b255239dd4d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -49,15 +49,13 @@ module Delay = struct (* Concrete type is the ends of a pipe *) type t = { (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option - ; mutable pipe_in: Unix.file_descr option + mutable pipe_in: Unix.file_descr option ; (* Indicates that a signal arrived before a wait: *) mutable signalled: bool ; m: M.t } - let make () = - {pipe_out= None; pipe_in= None; signalled= false; m= M.create ()} + let make () = {pipe_in= None; signalled= false; m= M.create ()} exception Pre_signalled @@ -80,7 +78,6 @@ module Delay = struct let pipe_out, pipe_in = Unix.pipe () in (* these will be unconditionally closed on exit *) to_close := [pipe_out; pipe_in] ; - x.pipe_out <- Some pipe_out ; x.pipe_in <- Some pipe_in ; x.signalled <- false ; pipe_out @@ -99,7 +96,6 @@ module Delay = struct ) (fun () -> Mutex.execute x.m (fun () -> - x.pipe_out <- None ; x.pipe_in <- None ; List.iter close' !to_close ) 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 407d025a8a8..350db0ee85c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,8 +1,14 @@ -(test +(library (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) + (libraries xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) +) + +(test + (name unixext_test_run) + (package xapi-stdext-unix) + (modules unixext_test_run) + (libraries unixext_test qcheck-core.runner) ; use fixed seed to avoid causing random failures in CI and package builds (action (run %{test} -v -bt --seed 42)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index e0f2726f303..656dcc1fe56 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -192,5 +192,4 @@ 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 + Xapi_stdext_unix.Unixext.test_open 1024 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 index e69de29bb2d..a10acd45016 100644 --- 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 @@ -0,0 +1 @@ +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml new file mode 100644 index 00000000000..74c7a62241b --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml @@ -0,0 +1 @@ +let () = QCheck_base_runner.run_tests_main Unixext_test.tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.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 ae2c92dc87b..5141e888fe8 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -303,7 +303,7 @@ let open_connection_unix_fd filename = module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: bytes + buffer: bytes ; mutable len: int (** bytes of valid data in [buffer] *) ; mutable start: int (** index of first valid byte in [buffer] *) ; mutable r_closed: bool (** true if no more data can be read due to EOF *) diff --git a/ocaml/libs/xml-light2/xml.ml b/ocaml/libs/xml-light2/xml.ml index 9b58f2f6cf0..38c38f1ff84 100644 --- a/ocaml/libs/xml-light2/xml.ml +++ b/ocaml/libs/xml-light2/xml.ml @@ -22,7 +22,7 @@ type xml = | Element of (string * (string * string) list * xml list) | PCData of string -type error_pos = {eline: int; eline_start: int; emin: int; emax: int} +type error_pos = {eline: int} type error = string * error_pos @@ -69,8 +69,8 @@ let _parse i = let parse i = try _parse i - with Xmlm.Error ((line, col), msg) -> - let pos = {eline= line; eline_start= line; emin= col; emax= col} in + with Xmlm.Error ((line, _), msg) -> + let pos = {eline= line} in let err = Xmlm.error_message msg in raise (Error (err, pos)) diff --git a/ocaml/license/dune b/ocaml/license/dune index 28ce39eb80f..e2ee71b2b3f 100644 --- a/ocaml/license/dune +++ b/ocaml/license/dune @@ -1,4 +1,5 @@ (library + (modes best) (name daily_license_check) (modules daily_license_check) (libraries @@ -18,7 +19,6 @@ (modules daily_license_check_main) (libraries daily_license_check - dune-build-info http_lib xapi-client xapi-types diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml index 5898d22f77f..2bc34621563 100644 --- a/ocaml/message-switch/async/protocol_async.ml +++ b/ocaml/message-switch/async/protocol_async.ml @@ -72,7 +72,7 @@ module M = struct | Ok (_, reader, writer) -> return (reader, writer) in - retry 1. + retry 0.5 let disconnect (_, writer) = Writer.close writer diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune index 41cbf9e9f2d..d61746efe44 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -13,6 +13,6 @@ xapi-log xapi-stdext-threads ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_deriving_rpc ppx_sexp_conv) Protocol))) ) diff --git a/ocaml/message-switch/core_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh index 877790370a2..bc281c65f45 100755 --- a/ocaml/message-switch/core_test/basic-rpc-test.sh +++ b/ocaml/message-switch/core_test/basic-rpc-test.sh @@ -3,38 +3,42 @@ set -e SPATH=${TMPDIR:-/tmp}/sock_s SWITCHPATH=${TMPDIR:-/tmp}/switch_s +SECS=${SECS:-0.1} - -rm -rf ${SWITCHPATH} && mkdir -p ${SWITCHPATH} +rm -rf "${SWITCHPATH}" && mkdir -p "${SWITCHPATH}" echo Test message switch serial processing echo Checking the switch can start late -./server_unix_main.exe -path $SPATH & -sleep 1 -../switch/switch_main.exe --path $SPATH --statedir ${SWITCHPATH} & -./client_unix_main.exe -path $SPATH -secs 5 -sleep 2 +./server_unix_main.exe -path "${SPATH}" & +SERVER=$! +sleep "${SECS}" +../switch/switch_main.exe --path "${SPATH}" --statedir "${SWITCHPATH}" & +./client_unix_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Unix to Unix -./server_unix_main.exe -path $SPATH & -./client_unix_main.exe -path $SPATH -secs 5 -sleep 2 +./server_unix_main.exe -path "${SPATH}" & +SERVER=$! +./client_unix_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Lwt to Lwt -lwt/server_main.exe -path $SPATH & -lwt/client_main.exe -path $SPATH -secs 5 -sleep 2 +lwt/server_main.exe -path "${SPATH}" & +SERVER=$! +lwt/client_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Async to Lwt -lwt/server_main.exe -path $SPATH & -async/client_async_main.exe -path $SPATH -secs 5 -sleep 2 +lwt/server_main.exe -path "${SPATH}" & +SERVER=$! +async/client_async_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Async to Async -async/server_async_main.exe -path $SPATH & -async/client_async_main.exe -path $SPATH -secs 5 -sleep 2 +async/server_async_main.exe -path "${SPATH}" & +SERVER=$! +async/client_async_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" -../cli/main.exe shutdown --path $SPATH -sleep 2 +../cli/main.exe shutdown --path "${SPATH}" diff --git a/ocaml/message-switch/core_test/dune b/ocaml/message-switch/core_test/dune index 449f2fae5c5..cda5c5125aa 100644 --- a/ocaml/message-switch/core_test/dune +++ b/ocaml/message-switch/core_test/dune @@ -57,6 +57,24 @@ (package message-switch) ) +(rule + (alias stresstest) + (deps + client_unix_main.exe + server_unix_main.exe + async/client_async_main.exe + async/server_async_main.exe + lwt/client_main.exe + lwt/server_main.exe + lwt/link_test_main.exe + ../switch/switch_main.exe + ../cli/main.exe + ) + (action (setenv SECS 5 (run ./basic-rpc-test.sh))) + (package message-switch) +) + + (rule (alias runtest) (deps diff --git a/ocaml/message-switch/lwt/protocol_lwt.ml b/ocaml/message-switch/lwt/protocol_lwt.ml index 26c9c874d55..af9ce1ce5c6 100644 --- a/ocaml/message-switch/lwt/protocol_lwt.ml +++ b/ocaml/message-switch/lwt/protocol_lwt.ml @@ -47,7 +47,7 @@ module M = struct (function | Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ECONNABORTED | Unix.ENOENT), _, _) -> - Lwt_unix.sleep 5. >>= fun () -> connect' () + Lwt_unix.sleep 0.5 >>= fun () -> connect' () | e -> Lwt_unix.close fd >>= fun () -> fail e ) diff --git a/ocaml/message-switch/switch/dune b/ocaml/message-switch/switch/dune index 756bb2d9097..e543584a896 100644 --- a/ocaml/message-switch/switch/dune +++ b/ocaml/message-switch/switch/dune @@ -28,7 +28,7 @@ sexplib0 uri ) - (preprocess (pps ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_sexp_conv) Logging Q Switch_main))) ) (install diff --git a/ocaml/message-switch/switch/logging.ml b/ocaml/message-switch/switch/logging.ml index 37101ac88fe..5eab8d89fa2 100644 --- a/ocaml/message-switch/switch/logging.ml +++ b/ocaml/message-switch/switch/logging.ml @@ -20,7 +20,6 @@ type logger = { stream: string Lwt_stream.t ; push: string -> unit ; elements: int ref - ; max_elements: int ; dropped_elements: int ref } @@ -35,13 +34,7 @@ let create max_elements = stream_push (Some line) ; incr !elements ) in - { - stream - ; push - ; elements= !elements - ; max_elements - ; dropped_elements= !dropped_elements - } + {stream; push; elements= !elements; dropped_elements= !dropped_elements} let get (logger : logger) = let return_lines all = diff --git a/ocaml/message-switch/unix/dune b/ocaml/message-switch/unix/dune index 54b6c0e77bf..be953217f4e 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -11,7 +11,8 @@ rpclib.core rpclib.json threads.posix + xapi-stdext-threads ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Protocol_unix_scheduler))) ) diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index a9b4984e4f4..7e4432a28f2 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -100,7 +100,7 @@ module IO = struct | Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ENOENT), _cmd, _) -> Unix.close fd ; (* wait for the server to start *) - Thread.delay 5. + Thread.delay 0.5 | e -> Unix.close fd ; raise e done ; diff --git a/ocaml/message-switch/unix/protocol_unix_scheduler.ml b/ocaml/message-switch/unix/protocol_unix_scheduler.ml index 92e6cdd3b1b..3eaeb83218c 100644 --- a/ocaml/message-switch/unix/protocol_unix_scheduler.ml +++ b/ocaml/message-switch/unix/protocol_unix_scheduler.ml @@ -34,71 +34,7 @@ module Int64Map = Map.Make (struct let compare = compare end) -module Delay = struct - (* Concrete type is the ends of a pipe *) - type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option - ; mutable pipe_in: Unix.file_descr option - ; (* Indicates that a signal arrived before a wait: *) - mutable signalled: bool - ; m: Mutex.t - } - - let make () = - {pipe_out= None; pipe_in= None; signalled= false; m= Mutex.create ()} - - exception Pre_signalled - - let wait (x : t) (seconds : float) = - let to_close = ref [] in - let close' fd = - if List.mem fd !to_close then Unix.close fd ; - to_close := List.filter (fun x -> fd <> x) !to_close - in - finally' - (fun () -> - try - let pipe_out = - Mutex.execute x.m (fun () -> - if x.signalled then ( - x.signalled <- false ; - raise Pre_signalled - ) ; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [pipe_out; pipe_in] ; - x.pipe_out <- Some pipe_out ; - x.pipe_in <- Some pipe_in ; - x.signalled <- false ; - pipe_out - ) - in - let r, _, _ = Unix.select [pipe_out] [] [] seconds in - (* flush the single byte from the pipe *) - if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; - (* return true if we waited the full length of time, false if we were woken *) - r = [] - with Pre_signalled -> false - ) - (fun () -> - Mutex.execute x.m (fun () -> - x.pipe_out <- None ; - x.pipe_in <- None ; - List.iter close' !to_close - ) - ) - - let signal (x : t) = - Mutex.execute x.m (fun () -> - match x.pipe_in with - | Some fd -> - ignore (Unix.write fd (Bytes.of_string "X") 0 1) - | None -> - x.signalled <- true - (* If the wait hasn't happened yet then store up the signal *) - ) -end +module Delay = Xapi_stdext_threads.Threadext.Delay type item = {id: int; name: string; fn: unit -> unit} diff --git a/ocaml/mpathalert/dune b/ocaml/mpathalert/dune index 569e98b8b35..2a46ae7e524 100644 --- a/ocaml/mpathalert/dune +++ b/ocaml/mpathalert/dune @@ -3,8 +3,7 @@ (name mpathalert) (public_name mpathalert) (package xapi) - (libraries - dune-build-info + (libraries http_lib threads.posix uuid diff --git a/ocaml/nbd/lib/dune b/ocaml/nbd/lib/dune index b712f67370c..8bcbdc6dd78 100644 --- a/ocaml/nbd/lib/dune +++ b/ocaml/nbd/lib/dune @@ -1,10 +1,12 @@ (library (name consts) + (modes best) (modules consts) ) (library (name local_xapi_session) + (modes best) (modules local_xapi_session) (libraries consts @@ -19,6 +21,7 @@ (library (name vbd_store) + (modes best) (libraries lwt lwt_log diff --git a/ocaml/nbd/src/dune b/ocaml/nbd/src/dune index 9f242944676..076e6884786 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -4,7 +4,7 @@ (libraries cmdliner consts - dune-build-info + local_xapi_session lwt lwt.unix diff --git a/ocaml/networkd/bin/dune b/ocaml/networkd/bin/dune index 7f154a0db5c..2b50b1e4159 100644 --- a/ocaml/networkd/bin/dune +++ b/ocaml/networkd/bin/dune @@ -16,7 +16,7 @@ (modes exe) (libraries astring - dune-build-info + forkexec http_lib integers diff --git a/ocaml/networkd/bin_db/dune b/ocaml/networkd/bin_db/dune index f36c68215de..b105b554b53 100644 --- a/ocaml/networkd/bin_db/dune +++ b/ocaml/networkd/bin_db/dune @@ -4,7 +4,7 @@ (package xapi-networkd) (modes exe) (libraries - dune-build-info + networklibs xapi-idl.network) ) diff --git a/ocaml/networkd/lib/dune b/ocaml/networkd/lib/dune index eb2f2de53cd..548d326a4b2 100644 --- a/ocaml/networkd/lib/dune +++ b/ocaml/networkd/lib/dune @@ -1,5 +1,6 @@ (library (name networklibs) + (modes best) (libraries astring forkexec diff --git a/ocaml/networkd/test/dune b/ocaml/networkd/test/dune index 92d3d968714..951eda074a0 100644 --- a/ocaml/networkd/test/dune +++ b/ocaml/networkd/test/dune @@ -1,9 +1,10 @@ (executable (name network_test) + (modes exe) (libraries alcotest astring - dune-build-info + fmt networklibs rpclib.core diff --git a/ocaml/perftest/dune b/ocaml/perftest/dune index 137511118b8..eb5bb586d5c 100644 --- a/ocaml/perftest/dune +++ b/ocaml/perftest/dune @@ -4,7 +4,7 @@ (public_name perftest) (package xapi) (libraries - dune-build-info + http_lib rpclib.core threads.posix diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index b5d02cc9496..c4044a7ebb7 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -6,7 +6,6 @@ (libraries alcotest astring - dune-build-info ezxenstore ezxenstore.watch fmt @@ -14,11 +13,14 @@ http_lib mtime mtime.clock.os + qcheck-alcotest result rresult rpclib.core rrdd_libs stunnel + bufio_test + test_timer threads.posix unix uuid diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index e09f4a92fbb..09c7f89c7c9 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -14,6 +14,11 @@ (** The main entry point of the quicktest executable *) +let qchecks = + [("bufio", Bufio_test.tests); ("Timer", Test_timer.tests)] + |> List.map @@ fun (name, test) -> + (name, List.map QCheck_alcotest.(to_alcotest ~long:true) test) + let () = Quicktest_args.parse () ; Qt_filter.wrap (fun () -> @@ -43,6 +48,11 @@ let () = [("http", Quicktest_http.tests)] else [] + @ + if not !Quicktest_args.skip_stress then + qchecks + else + [] in (* Only list tests if asked, without running them *) if !Quicktest_args.list_tests then diff --git a/ocaml/quicktest/quicktest_args.ml b/ocaml/quicktest/quicktest_args.ml index d9659ba9105..cc05b27b667 100644 --- a/ocaml/quicktest/quicktest_args.ml +++ b/ocaml/quicktest/quicktest_args.ml @@ -45,6 +45,8 @@ let set_alcotest_args l = alcotest_args := Array.of_list l let skip_xapi = ref false +let skip_stress = 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. *) @@ -67,6 +69,7 @@ let parse () = -default-sr" ) ; ("-skip-xapi", Arg.Set skip_xapi, "SKIP tests that require XAPI") + ; ("-skip-stress", Arg.Set skip_stress, "SKIP randomized stress tests") ; ("--", Arg.Rest_all set_alcotest_args, "Supply alcotest arguments") ; ( "-run-only" , Arg.String (fun x -> run_only := Some x) diff --git a/ocaml/rrd2csv/src/dune b/ocaml/rrd2csv/src/dune index 6c891c32a94..ce263d70a01 100644 --- a/ocaml/rrd2csv/src/dune +++ b/ocaml/rrd2csv/src/dune @@ -4,7 +4,7 @@ (public_name rrd2csv) (package rrd2csv) (libraries - dune-build-info + http_lib threads.posix xapi-idl.rrd diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 13fdef256c4..0448c4e067f 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -143,10 +143,9 @@ module Ds_selector = struct ; owner: Rrd.ds_owner option ; uuid: string ; metric: string - ; enabled: bool } - let empty = {cf= None; owner= None; uuid= ""; metric= ""; enabled= true} + let empty = {cf= None; owner= None; uuid= ""; metric= ""} let of_string str = let open Rrd in @@ -154,7 +153,6 @@ module Ds_selector = struct match splitted with | [cf; owner; uuid; metric] -> { - empty with cf= (try Some (cf_type_of_string cf) with _ -> None) ; owner= ( match owner with @@ -351,9 +349,7 @@ module Xport = struct (* Xport.t structure *) type meta = { - time_start: int64 - ; time_step: int64 - ; time_end: int64 + time_step: int64 ; entries: Ds_selector.t list (* XXX: remove when merging *) (* entries: Ds_selector.t list; *) @@ -411,9 +407,7 @@ module Xport = struct let process_meta (elts : xml_tree list) = let kvs = kvs elts in { - time_start= Int64.of_string (List.assoc "start" kvs) - ; time_step= Int64.of_string (List.assoc "step" kvs) - ; time_end= Int64.of_string (List.assoc "end" kvs) + time_step= Int64.of_string (List.assoc "step" kvs) ; entries= process_legend (find_elt "legend" elts) } in diff --git a/ocaml/sdk-gen/c/dune b/ocaml/sdk-gen/c/dune index ec5812bda74..79cb32b80c6 100644 --- a/ocaml/sdk-gen/c/dune +++ b/ocaml/sdk-gen/c/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-datamodel ) diff --git a/ocaml/sdk-gen/common/dune b/ocaml/sdk-gen/common/dune index 71ac6f30230..777d29b16ce 100644 --- a/ocaml/sdk-gen/common/dune +++ b/ocaml/sdk-gen/common/dune @@ -1,5 +1,6 @@ (library (name CommonFunctions) + (modes best) (wrapped false) (libraries astring diff --git a/ocaml/sdk-gen/csharp/dune b/ocaml/sdk-gen/csharp/dune index 417dca4d4b1..e7112b1aae9 100644 --- a/ocaml/sdk-gen/csharp/dune +++ b/ocaml/sdk-gen/csharp/dune @@ -5,7 +5,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-consts xapi-datamodel @@ -18,7 +18,7 @@ (modules Friendly_error_names) (libraries CommonFunctions - dune-build-info + mustache xapi-datamodel xmllight2 diff --git a/ocaml/sdk-gen/go/dune b/ocaml/sdk-gen/go/dune index 7303bc0c438..6d99103516a 100644 --- a/ocaml/sdk-gen/go/dune +++ b/ocaml/sdk-gen/go/dune @@ -14,6 +14,7 @@ (library (name gen_go_helper) (modules gen_go_helper) + (modes best) (libraries CommonFunctions astring diff --git a/ocaml/sdk-gen/java/dune b/ocaml/sdk-gen/java/dune index 2588d3ba785..498b3a7bc09 100644 --- a/ocaml/sdk-gen/java/dune +++ b/ocaml/sdk-gen/java/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache str xapi-datamodel diff --git a/ocaml/sdk-gen/powershell/dune b/ocaml/sdk-gen/powershell/dune index b0f1fe83a4b..39b2f99b75f 100644 --- a/ocaml/sdk-gen/powershell/dune +++ b/ocaml/sdk-gen/powershell/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-datamodel ) diff --git a/ocaml/squeezed/lib/dune b/ocaml/squeezed/lib/dune index 20612fecef6..e5bd06deb89 100644 --- a/ocaml/squeezed/lib/dune +++ b/ocaml/squeezed/lib/dune @@ -1,5 +1,6 @@ (library (name squeeze) + (modes best) (flags (:standard -bin-annot)) (libraries re diff --git a/ocaml/squeezed/src/dune b/ocaml/squeezed/src/dune index c5d6683ad92..4db102ad8a0 100644 --- a/ocaml/squeezed/src/dune +++ b/ocaml/squeezed/src/dune @@ -10,7 +10,7 @@ xapi-stdext-unix xapi_version astring - dune-build-info + rpclib.core squeeze threads.posix diff --git a/ocaml/tapctl/dune b/ocaml/tapctl/dune index 3c585047e79..903e35a63d4 100644 --- a/ocaml/tapctl/dune +++ b/ocaml/tapctl/dune @@ -1,5 +1,6 @@ (library (name tapctl) + (modes best) (wrapped false) (preprocess (pps ppx_deriving_rpc)) (libraries diff --git a/ocaml/tests/alerts/dune b/ocaml/tests/alerts/dune index 613f4077eaa..d7f29a5fa76 100644 --- a/ocaml/tests/alerts/dune +++ b/ocaml/tests/alerts/dune @@ -5,7 +5,7 @@ alcotest certificate_check daily_license_check - dune-build-info + expiry_alert fmt xapi-consts diff --git a/ocaml/tests/common/suite_init.ml b/ocaml/tests/common/suite_init.ml index e5c73554295..ee0317811b1 100644 --- a/ocaml/tests/common/suite_init.ml +++ b/ocaml/tests/common/suite_init.ml @@ -8,4 +8,4 @@ let harness_init () = Filename.concat Test_common.working_area "xapi-inventory" ; Xcp_client.use_switch := false ; Pool_role.set_pool_role_for_test () ; - Xapi.register_callback_fns () + Message_forwarding.register_callback_fns () diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index 90dfe287801..1c1685f693d 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -527,27 +527,6 @@ let make_session ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ~client_certificate ; ref -(** Returns a [(rpc, session_id)] pair that can be passed to the - functions within the [Client] module to make XenAPI calls. The - calls can only succeed if they get forwarded to the local host - by the message forwarding layer. Forwarding to slaves does not - work in unit tests. *) -let make_client_params ~__context = - let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in - let rpc = Api_server.Server.dispatch_call req Unix.stdout in - let session_id = - let session_id = Ref.make () in - let now = Xapi_stdext_date.Date.of_float (Unix.time ()) in - let (_ : _ API.Ref.t) = - make_session ~__context ~ref:session_id - ~this_host:(Helpers.get_localhost ~__context) - ~last_active:now ~is_local_superuser:true ~validation_time:now - ~auth_user_name:"root" ~originator:"test" () - in - session_id - in - (rpc, session_id) - let create_physical_pif ~__context ~host ?network ?(bridge = "xapi0") ?(managed = true) () = let network = diff --git a/ocaml/tests/dune b/ocaml/tests/dune index d48056d3b70..7cc177ba586 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -5,8 +5,9 @@ (modules (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_network_sriov + test_client test_valid_ref_list suite_alcotest_server test_vm_placement test_vm_helpers test_repository test_repository_helpers - test_ref + test_ref test_vm_group test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer test_pool_periodic_update_sync test_pkg_mgr)) (libraries @@ -14,7 +15,7 @@ angstrom astring cstruct - dune-build-info + fmt http_lib httpsvr @@ -30,7 +31,6 @@ threads.posix uuid xapi-backtrace - xapi-client xapi_cli_server xapi-consts xapi_database @@ -52,12 +52,30 @@ xapi-xenopsd xml-light2 ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) (deps (source_tree test_data) ) ) +(test + (name suite_alcotest_server) + (package xapi) + (modules suite_alcotest_server test_client test_valid_ref_list test_vm_group) + (libraries + alcotest + httpsvr + tests_common + xapi-client + http_lib + xapi-log + xapi-stdext-date + xapi-types + xapi_internal + xapi_internal_server + ) +) + + (tests (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index be73d7cef06..c2e422c2379 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -5,8 +5,7 @@ let () = Debug.log_to_stdout () ; Alcotest.run "Base suite" ([ - ("Test_valid_ref_list", Test_valid_ref_list.test) - ; ("Test_sdn_controller", Test_sdn_controller.test) + ("Test_sdn_controller", Test_sdn_controller.test) ; ("Test_pci_helpers", Test_pci_helpers.test) ; ("Test_vdi_allowed_operations", Test_vdi_allowed_operations.test) ; ("Test_sr_allowed_operations", Test_sr_allowed_operations.test) @@ -27,7 +26,6 @@ let () = ; ( "Test_clustering_allowed_operations" , Test_clustering_allowed_operations.test ) - ; ("Test_client", Test_client.test) ; ("Test_ca91480", Test_ca91480.test) ; ("Test_pgpu", Test_pgpu.test) ; ("Test_gpu_group", Test_gpu_group.test) @@ -46,7 +44,6 @@ let () = ; ("Test_storage_migrate_state", Test_storage_migrate_state.test) ; ("Test_bios_strings", Test_bios_strings.test) ; ("Test_certificates", Test_certificates.test) - ; ("Test_vm_group", Test_vm_group.test) ] @ Test_guest_agent.tests @ Test_nm.tests diff --git a/ocaml/tests/suite_alcotest_server.ml b/ocaml/tests/suite_alcotest_server.ml new file mode 100644 index 00000000000..9b6f03b0c0e --- /dev/null +++ b/ocaml/tests/suite_alcotest_server.ml @@ -0,0 +1,11 @@ +let () = + Suite_init.harness_init () ; + (* Alcotest hides the standard output of successful tests, + so we will probably not exceed the 4MB limit in Travis *) + Debug.log_to_stdout () ; + Alcotest.run "Base suite" + [ + ("Test_valid_ref_list", Test_valid_ref_list.test) + ; ("Test_client", Test_client.test) + ; ("Test_vm_group", Test_vm_group.test) + ] diff --git a/ocaml/tests/test_client.ml b/ocaml/tests/test_client.ml index 0a5c64630ab..cdfa7690f79 100644 --- a/ocaml/tests/test_client.ml +++ b/ocaml/tests/test_client.ml @@ -3,9 +3,31 @@ these XenAPI calls go through the client, server.ml, message forwarding, and database layers. *) +(** Returns a [(rpc, session_id)] pair that can be passed to the + functions within the [Client] module to make XenAPI calls. The + calls can only succeed if they get forwarded to the local host + by the message forwarding layer. Forwarding to slaves does not + work in unit tests. *) +let make_client_params ~__context = + let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in + let rpc = Api_server.Server.dispatch_call req Unix.stdout in + let session_id = + let session_id = Ref.make () in + let now = Xapi_stdext_date.Date.of_float (Unix.time ()) in + let (_ : _ API.Ref.t) = + Test_common.make_session ~__context ~ref:session_id + ~this_host:(Helpers.get_localhost ~__context) + ~last_active:now ~is_local_superuser:true ~validation_time:now + ~auth_user_name:"root" ~originator:"test" () + in + session_id + in + (rpc, session_id) + let setup_test () = + Xapi.register_callback_fns () ; let __context = Test_common.make_test_database () in - Test_common.make_client_params ~__context + make_client_params ~__context (* Here we should have a unit test for each different type of method, such as X.create, X.destroy, getters, and setters, to ensure that these are diff --git a/ocaml/tests/test_valid_ref_list.ml b/ocaml/tests/test_valid_ref_list.ml index 56cdaccbaa5..d7b5273bdc8 100644 --- a/ocaml/tests/test_valid_ref_list.ml +++ b/ocaml/tests/test_valid_ref_list.ml @@ -111,7 +111,7 @@ let test_iter = exceptions when we use the Client module *) let test_client = with_vm_list (fun __context l -> - let rpc, session_id = Test_common.make_client_params ~__context in + let rpc, session_id = Test_client.make_client_params ~__context in let f vm = Client.Client.VM.get_name_label ~rpc ~session_id ~self:vm in assert_equal ["a"; "d"] (Valid_ref_list.map f l) ) diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 566fa18fbf5..3137e0485cb 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -475,7 +475,7 @@ let test_allowed_operations_updated_when_necessary () = List.mem `copy ops ) ; (* Call data_destroy through the the message forwarding layer *) - Api_server.Forwarder.VDI.data_destroy ~__context ~self ; + Api_server_common.Forwarder.VDI.data_destroy ~__context ~self ; assert_allowed_operations "does not contain `copy after VDI has been data-destroyed" (fun ops -> not @@ List.mem `copy ops diff --git a/ocaml/tests/test_vm_check_operation_error.ml b/ocaml/tests/test_vm_check_operation_error.ml index 567ac89f49f..5116ac55d1c 100644 --- a/ocaml/tests/test_vm_check_operation_error.ml +++ b/ocaml/tests/test_vm_check_operation_error.ml @@ -34,7 +34,8 @@ let test_vm_set_nvram_running () = with_test_vm (fun __context vm_ref -> Db.VM.set_power_state ~__context ~self:vm_ref ~value:`Halted ; let old_nvram = [("EFI-variables", "AAAA")] in - Api_server.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref ~value:old_nvram ; + Api_server_common.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref + ~value:old_nvram ; Db.VM.set_power_state ~__context ~self:vm_ref ~value:`Running ; Alcotest.check_raises "VM.set_NVRAM should fail when the VM is running" Api_errors.( @@ -42,7 +43,7 @@ let test_vm_set_nvram_running () = (vm_bad_power_state, [Ref.string_of vm_ref; "halted"; "running"]) ) (fun () -> - Api_server.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref + Api_server_common.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref ~value:[("EFI-variables", "BBBB")] ) ; let read_nvram = Db.VM.get_NVRAM ~__context ~self:vm_ref in @@ -50,8 +51,8 @@ let test_vm_set_nvram_running () = "NVRAM not updated" old_nvram read_nvram ; let new_vars = "CCCC" in let new_nvram = [("EFI-variables", new_vars)] in - Api_server.Forwarder.VM.set_NVRAM_EFI_variables ~__context ~self:vm_ref - ~value:new_vars ; + Api_server_common.Forwarder.VM.set_NVRAM_EFI_variables ~__context + ~self:vm_ref ~value:new_vars ; let read_nvram = Db.VM.get_NVRAM ~__context ~self:vm_ref in Alcotest.(check (list (pair string string))) "NVRAM updated" new_nvram read_nvram diff --git a/ocaml/tests/test_vm_group.ml b/ocaml/tests/test_vm_group.ml index 910711f9646..8e45cf050cc 100644 --- a/ocaml/tests/test_vm_group.ml +++ b/ocaml/tests/test_vm_group.ml @@ -16,7 +16,7 @@ module T = Test_common let test_associate_vm_with_vm_group () = let __context = T.make_test_database () in - let rpc, session_id = Test_common.make_client_params ~__context in + let rpc, session_id = Test_client.make_client_params ~__context in let vm1 = T.make_vm ~__context () in let vm2 = T.make_vm ~__context () in let vm3 = T.make_vm ~__context () in @@ -34,7 +34,7 @@ let test_associate_vm_with_vm_group () = let test_vm_can_only_belong_to_one_group () = let __context = T.make_test_database () in - let rpc, session_id = Test_common.make_client_params ~__context in + let rpc, session_id = Test_client.make_client_params ~__context in let vm = T.make_vm ~__context () in let vm_group1 = T.make_vm_group ~__context ~placement:`anti_affinity () in let vm_group2 = T.make_vm_group ~__context ~placement:`anti_affinity () in diff --git a/ocaml/util/dune b/ocaml/util/dune index 2aeb1e2e5a2..7a21f9bb24b 100644 --- a/ocaml/util/dune +++ b/ocaml/util/dune @@ -11,8 +11,8 @@ ; we don't want it inlined (flags (:standard -opaque)) (libraries - xapi-inventory dune-build-info + xapi-inventory ) (wrapped false) ) diff --git a/ocaml/util/xapi_version.ml b/ocaml/util/xapi_version.ml index 90e71077898..4b36a646e61 100644 --- a/ocaml/util/xapi_version.ml +++ b/ocaml/util/xapi_version.ml @@ -46,3 +46,9 @@ let compare_version version_a version_b = let maj_b, min_b, _ = parse_xapi_version version_b in let ( ) a b = if a = 0 then b else a in Int.compare maj_a maj_b Int.compare min_a min_b 0 + +let xapi_user_agent = + "xapi/" + ^ string_of_int xapi_version_major + ^ "." + ^ string_of_int xapi_version_minor diff --git a/ocaml/util/xapi_version.mli b/ocaml/util/xapi_version.mli index 77d6e5ef022..97bdbe8837a 100644 --- a/ocaml/util/xapi_version.mli +++ b/ocaml/util/xapi_version.mli @@ -25,3 +25,5 @@ val xapi_version_major : int val xapi_version_minor : int val compare_version : string -> string -> int + +val xapi_user_agent : string diff --git a/ocaml/vhd-tool/cli/dune b/ocaml/vhd-tool/cli/dune index 63f017a92d4..cb85ba1a1dc 100644 --- a/ocaml/vhd-tool/cli/dune +++ b/ocaml/vhd-tool/cli/dune @@ -5,7 +5,7 @@ (public_names vhd-tool sparse_dd get_vhd_vsize) (libraries astring - dune-build-info + local_lib cmdliner cstruct diff --git a/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml b/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml deleted file mode 100644 index aebc7c1d716..00000000000 --- a/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml +++ /dev/null @@ -1,129 +0,0 @@ -(* - * Copyright (c) 2012 Citrix Inc - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -type 'a t = 'a Lwt.t - -let iter fn x = Lwt_list.iter_s fn x - -let return = Lwt.return - -let ( >>= ) = Lwt.bind - -let ( >> ) m n = m >>= fun _ -> n - -(** Use as few really_{read,write} calls as we can (for efficiency) without - explicitly buffering the stream beyond the HTTP headers. This will - allow us to consume the headers and then pass the file descriptor - safely to another process *) - -type ic = { - mutable header_buffer: string option (** buffered headers *) - ; mutable header_buffer_idx: int (** next char within the buffered headers *) - ; c: Channels.t -} - -let make_input c = - let header_buffer = None in - let header_buffer_idx = 0 in - {header_buffer; header_buffer_idx; c} - -type oc = Channels.t - -type conn = Channels.t - -let really_read_into c buf ofs len = - let tmp = Cstruct.create len in - c.Channels.really_read tmp >>= fun () -> - Cstruct.blit_to_bytes tmp 0 buf ofs len ; - return () - -let read_http_headers c = - let buf = Buffer.create 128 in - (* We can safely read everything up to this marker: *) - let end_of_headers = "\r\n\r\n" in - let tmp = Bytes.make (String.length end_of_headers) '\000' in - let module Scanner = struct - type t = {marker: string; mutable i: int} - - let make x = {marker= x; i= 0} - - let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 - - let remaining x = String.length x.marker - x.i - - let matched x = x.i = String.length x.marker - end in - let marker = Scanner.make end_of_headers in - - let rec loop () = - if not (Scanner.matched marker) then ( - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) - let safe_to_read = Scanner.remaining marker in - - really_read_into c tmp 0 safe_to_read >>= fun () -> - for j = 0 to safe_to_read - 1 do - Scanner.input marker (Bytes.get tmp j) ; - Buffer.add_char buf (Bytes.get tmp j) - done ; - loop () - ) else - return () - in - loop () >>= fun () -> return (Buffer.contents buf) - -(* We assume read_line is only used to read the HTTP header *) -let rec read_line ic = - match (ic.header_buffer, ic.header_buffer_idx) with - | None, _ -> - read_http_headers ic.c >>= fun str -> - ic.header_buffer <- Some str ; - read_line ic - | Some buf, i when i < String.length buf -> ( - match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with - | Some eol -> - let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2 ; - return (Some line) - | None -> - return (Some "") - ) - | Some _, _ -> - return (Some "") - -let read_into_exactly ic buf ofs len = - really_read_into ic.c buf ofs len >>= fun () -> return true - -let read_exactly ic len = - let buf = Bytes.create len in - read_into_exactly ic buf 0 len >>= function - | true -> - return (Some buf) - | false -> - return None - -let read ic n = - let buf = Bytes.make n '\000' in - really_read_into ic.c buf 0 n >>= fun () -> return (Bytes.unsafe_to_string buf) - -let write oc x = - let buf = Cstruct.create (String.length x) in - Cstruct.blit_from_string x 0 buf 0 (String.length x) ; - oc.Channels.really_write buf - -let flush _oc = return () diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 0d8436915ae..8d278eefa07 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -1,4 +1,5 @@ (library + (modes best) (foreign_stubs (language c) (names direct_copy_stubs) @@ -11,6 +12,7 @@ cohttp cohttp-lwt cstruct + (re_export ezxenstore) io-page lwt lwt.unix @@ -30,12 +32,16 @@ tapctl xapi-stdext-std xapi-stdext-unix + xen-api-client-lwt xenstore xenstore.client xenstore.unix xenstore_transport xenstore_transport.unix ) - (preprocess (pps ppx_deriving_rpc ppx_cstruct)) + (preprocess + (per_module + ((pps ppx_deriving_rpc) Nbd_input Image) + ((pps ppx_cstruct) Chunked))) ) diff --git a/ocaml/vhd-tool/src/impl.ml b/ocaml/vhd-tool/src/impl.ml index 6e699650cfc..54058316625 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -954,6 +954,27 @@ let make_stream common source relative_to source_format destination_format = | _, _ -> assert false +module ChannelsConstrained : sig + type t = Channels.t + + type reader = Cstruct.t -> unit Lwt.t + + val really_read : t -> reader + + val really_write : t -> reader +end = struct + type t = Channels.t + + type reader = Cstruct.t -> unit Lwt.t + + let really_read x = x.Channels.really_read + + let really_write x = x.Channels.really_write +end + +module Cohttp_io_with_channels = + Xen_api_client_lwt.Cohttp_unbuffered_io.Make (ChannelsConstrained) + (** [write_stream common s destination destination_protocol prezeroed progress tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites] writes the data stream [s] to [destination], using the specified @@ -1019,8 +1040,8 @@ let write_stream common s destination destination_protocol prezeroed progress Channels.of_raw_fd sock ) >>= fun c -> - let module Request = Request.Make (Cohttp_unbuffered_io) in - let module Response = Response.Make (Cohttp_unbuffered_io) in + let module Request = Request.Make (Cohttp_io_with_channels) in + let module Response = Response.Make (Cohttp_io_with_channels) in let headers = Header.init () in let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in let headers = Header.add headers k v in @@ -1044,7 +1065,7 @@ let write_stream common s destination destination_protocol prezeroed progress Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri' in Request.write (fun _ -> return ()) request c >>= fun () -> - Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r -> + Response.read (Cohttp_io_with_channels.make_input c) >>= fun r -> match r with | `Invalid x -> fail (Failure (Printf.sprintf "Invalid HTTP response: %s" x)) diff --git a/ocaml/vhd-tool/src/xenstore.ml b/ocaml/vhd-tool/src/xenstore.ml index 603a86e8f60..b0c0dfd9e8d 100644 --- a/ocaml/vhd-tool/src/xenstore.ml +++ b/ocaml/vhd-tool/src/xenstore.ml @@ -12,102 +12,4 @@ * GNU Lesser General Public License for more details. *) -let error fmt = Printf.ksprintf (output_string stderr) fmt - -module Client = Xs_client_unix.Client (Xs_transport_unix_client) - -let make_client () = - try Client.make () - with e -> - error "Failed to connect to xenstore. The raw error was: %s" - (Printexc.to_string e) ; - ( match e with - | Unix.Unix_error (Unix.EACCES, _, _) -> - error "Access to xenstore was denied." ; - let euid = Unix.geteuid () in - if euid <> 0 then ( - error "My effective uid is %d." euid ; - error "Typically xenstore can only be accessed by root (uid 0)." ; - error "Please switch to root (uid 0) and retry." - ) - | Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> - error "Access to xenstore was refused." ; - error "This normally indicates that the service is not running." ; - error "Please start the xenstore service and retry." - | _ -> - () - ) ; - raise e - -let get_client = - let client = ref None in - fun () -> - match !client with - | None -> - let c = make_client () in - client := Some c ; - c - | Some c -> - c - -type domid = int - -module Xs = struct - type domid = int - - type xsh = { - (* - debug: string list -> string; -*) - directory: string -> string list - ; read: string -> string - ; (* - readv : string -> string list -> string list; -*) - write: string -> string -> unit - ; writev: string -> (string * string) list -> unit - ; mkdir: string -> unit - ; rm: string -> unit - ; (* - getperms : string -> perms; - setpermsv : string -> string list -> perms -> unit; - release : domid -> unit; - resume : domid -> unit; -*) - setperms: string -> Xs_protocol.ACL.t -> unit - ; getdomainpath: domid -> string - ; watch: string -> string -> unit - ; unwatch: string -> string -> unit - ; introduce: domid -> nativeint -> int -> unit - ; set_target: domid -> domid -> unit - } - - let ops h = - { - read= Client.read h - ; directory= Client.directory h - ; write= Client.write h - ; writev= - (fun base_path -> - List.iter (fun (k, v) -> Client.write h (base_path ^ "/" ^ k) v) - ) - ; mkdir= Client.mkdir h - ; rm= (fun path -> try Client.rm h path with Xs_protocol.Enoent _ -> ()) - ; setperms= Client.setperms h - ; getdomainpath= Client.getdomainpath h - ; watch= Client.watch h - ; unwatch= Client.unwatch h - ; introduce= Client.introduce h - ; set_target= Client.set_target h - } - - let with_xs f = Client.immediate (get_client ()) (fun h -> f (ops h)) - - let wait f = Client.wait (get_client ()) (fun h -> f (ops h)) - - let transaction _ f = Client.transaction (get_client ()) (fun h -> f (ops h)) -end - -module Xst = Xs - -let with_xs = Xs.with_xs +include Ezxenstore_core.Xenstore diff --git a/ocaml/vncproxy/dune b/ocaml/vncproxy/dune index b384086d377..5e6e1d768d8 100644 --- a/ocaml/vncproxy/dune +++ b/ocaml/vncproxy/dune @@ -4,7 +4,7 @@ (public_name vncproxy) (package xapi) (libraries - dune-build-info + http_lib stunnel xapi-client diff --git a/ocaml/wsproxy/src/dune b/ocaml/wsproxy/src/dune index 34989429d26..8513c2998c3 100644 --- a/ocaml/wsproxy/src/dune +++ b/ocaml/wsproxy/src/dune @@ -1,4 +1,5 @@ (library (name wslib) + (modes best) (libraries base64 lwt lwt.unix) ) diff --git a/ocaml/xapi-aux/dune b/ocaml/xapi-aux/dune index 29f72161907..86fbd8647c9 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -1,5 +1,6 @@ (library (name xapi_aux) + (modes best) (libraries astring cstruct @@ -14,7 +15,6 @@ xapi-log xapi-stdext-threads xapi-stdext-unix - xapi-types xml-light2 ) (wrapped false) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 5940803f59e..433e7a3625b 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -4578,7 +4578,7 @@ let vm_migrate printer rpc session_id params = let pwd = List.assoc "remote-password" params in let remote_session = Client.Session.login_with_password ~rpc:remote_rpc ~uname ~pwd - ~version:"1.3" ~originator:Constants.xapi_user_agent + ~version:"1.3" ~originator:Xapi_version.xapi_user_agent in let remote f = f ~rpc:remote_rpc ~session_id:remote_session in finally diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index 8f583541481..ff3efb6c7b0 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -18,6 +18,7 @@ threads.posix xapi-backtrace xapi-consts + xapi_version xapi_database xapi-datamodel xapi-log diff --git a/ocaml/xapi-consts/api_messages.ml b/ocaml/xapi-consts/api_messages.ml index 5d9160152c2..ff436199a76 100644 --- a/ocaml/xapi-consts/api_messages.ml +++ b/ocaml/xapi-consts/api_messages.ml @@ -311,6 +311,8 @@ let cluster_host_leaving = addMessage "CLUSTER_HOST_LEAVING" 3L let cluster_host_joining = addMessage "CLUSTER_HOST_JOINING" 4L +let cluster_stack_out_of_date = addMessage "CLUSTER_STACK_OUT_OF_DATE" 3L + (* Certificate expiration messages *) let host_server_certificate_expiring = "HOST_SERVER_CERTIFICATE_EXPIRING" diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index 2e38e24bdfa..356c6ac6914 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -378,14 +378,6 @@ let http_limit_max_rpc_size = 300 * 1024 (* 300K *) let http_limit_max_cli_size = 200 * 1024 (* 200K *) -(* xapi version *) -let version_major = Xapi_version.xapi_version_major - -let version_minor = Xapi_version.xapi_version_minor - -let xapi_user_agent = - "xapi/" ^ string_of_int version_major ^ "." ^ string_of_int version_minor - (* Path to the pool configuration file. *) let pool_config_file = ref (Filename.concat "/etc/xensource" "pool.conf") diff --git a/ocaml/xapi-consts/dune b/ocaml/xapi-consts/dune index f5c35c96ed5..1c37b347206 100644 --- a/ocaml/xapi-consts/dune +++ b/ocaml/xapi-consts/dune @@ -2,8 +2,4 @@ (name xapi_consts) (public_name xapi-consts) (wrapped false) - (libraries - xapi_version - ) ) - diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index dd35baf40cb..e4eebc4cd80 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -1,7 +1,8 @@ (library (name xapi_guard_server) (modules server_interface) - (libraries + (modes best) +(libraries cohttp cohttp-lwt cohttp-lwt-unix @@ -51,4 +52,4 @@ xapi-idl.guard.privileged xapi-idl.guard.varstored ) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Types Varstored_interface)))) diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index ac7a6665c1a..7c48635b73b 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -4,7 +4,7 @@ (libraries astring cmdliner - dune-build-info + lwt lwt.unix message-switch-lwt diff --git a/ocaml/xapi-guard/test/dune b/ocaml/xapi-guard/test/dune index 9d44fdefbac..5c98ec22658 100644 --- a/ocaml/xapi-guard/test/dune +++ b/ocaml/xapi-guard/test/dune @@ -5,7 +5,7 @@ (libraries alcotest alcotest-lwt - dune-build-info + fmt lwt rpclib.core diff --git a/ocaml/xapi-idl/README.md b/ocaml/xapi-idl/README.md index 3b34349a152..2da87aa0c20 100644 --- a/ocaml/xapi-idl/README.md +++ b/ocaml/xapi-idl/README.md @@ -10,7 +10,6 @@ This repository contains * argument parsing * RPCs 3. The following CLI tools for debugging: - * lib/channel_helper.exe -- a channel passing helper CLI * memory/memory_cli.exe -- a squeezed debugging CLI * v6/v6_cli.exe -- a V6d debugging CLI * cluster/cluster_cli.exe -- a xapi-clusterd debugging CLI diff --git a/ocaml/xapi-idl/guard/privileged/dune b/ocaml/xapi-idl/guard/privileged/dune index eff7682e710..cdb888692d1 100644 --- a/ocaml/xapi-idl/guard/privileged/dune +++ b/ocaml/xapi-idl/guard/privileged/dune @@ -18,7 +18,7 @@ (package varstored-guard) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/guard/varstored/dune b/ocaml/xapi-idl/guard/varstored/dune index a54af22988a..abded2e1c17 100644 --- a/ocaml/xapi-idl/guard/varstored/dune +++ b/ocaml/xapi-idl/guard/varstored/dune @@ -17,7 +17,7 @@ (modules varstored_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index c8feec1ff1a..ab2f7ab6a0c 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -7,14 +7,12 @@ cmdliner cohttp cohttp-posix - (re_export dune-build-info) fd-send-recv logs message-switch-core message-switch-unix mtime mtime.clock.os - ppx_sexp_conv.runtime-lib re rpclib.core rpclib.json @@ -38,7 +36,10 @@ xmlm ) (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) + (preprocess + (per_module + ((pps ppx_deriving_rpc) Xcp_channel Xcp_channel_protocol TypeCombinators) + ((pps ppx_sexp_conv ppx_deriving_rpc) Xcp_pci)))) (library (name xcp_updates) @@ -60,4 +61,4 @@ xapi-stdext-threads ) (wrapped false) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Updates Scheduler)))) diff --git a/ocaml/xapi-idl/lib/posix_channel.ml b/ocaml/xapi-idl/lib/posix_channel.ml deleted file mode 100644 index 06708561011..00000000000 --- a/ocaml/xapi-idl/lib/posix_channel.ml +++ /dev/null @@ -1,234 +0,0 @@ -let my_domid = 0 (* TODO: figure this out *) - -exception End_of_file - -exception Channel_setup_failed - -module CBuf = struct - (** A circular buffer constructed from a string *) - type t = { - mutable buffer: bytes - ; mutable len: int (** bytes of valid data in [buffer] *) - ; mutable start: int (** index of first valid byte in [buffer] *) - ; mutable r_closed: bool (** true if no more data can be read due to EOF *) - ; mutable w_closed: bool - (** true if no more data can be written due to EOF *) - } - - let empty length = - { - buffer= Bytes.create length - ; len= 0 - ; start= 0 - ; r_closed= false - ; w_closed= false - } - - let drop (x : t) n = - if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len) ; - x.start <- (x.start + n) mod Bytes.length x.buffer ; - x.len <- x.len - n - - let should_read (x : t) = - (not x.r_closed) && x.len < Bytes.length x.buffer - 1 - - let should_write (x : t) = (not x.w_closed) && x.len > 0 - - let end_of_reads (x : t) = x.r_closed && x.len = 0 - - let end_of_writes (x : t) = x.w_closed - - let write (x : t) fd = - (* Offset of the character after the substring *) - let next = min (Bytes.length x.buffer) (x.start + x.len) in - let len = next - x.start in - let written = - try Unix.single_write fd x.buffer x.start len - with _e -> - x.w_closed <- true ; - len - in - drop x written - - let read (x : t) fd = - (* Offset of the next empty character *) - let next = (x.start + x.len) mod Bytes.length x.buffer in - let len = - min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) - in - let read = Unix.read fd x.buffer next len in - if read = 0 then x.r_closed <- true ; - x.len <- x.len + read -end - -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] *) - (* [b'] is read from [b] and will be written to [a] *) - let a' = CBuf.empty size and b' = CBuf.empty size in - Unix.set_nonblock a ; - Unix.set_nonblock b ; - 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 [] - 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 there's nothing else to read or write then signal the other end *) - List.iter - (fun (buf, fd) -> - if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND ; - if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE - ) - [(a', b); (b', a)] - done - with _ -> ( - (try Unix.clear_nonblock a with _ -> ()) ; - try Unix.clear_nonblock b with _ -> () - ) - -let finally f g = - try - let result = f () in - g () ; result - with e -> g () ; raise e - -let ip = ref "127.0.0.1" - -let send proxy_socket = - let to_close = ref [] in - let to_unlink = ref [] in - finally - (fun () -> - let s_ip = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - to_close := s_ip :: !to_close ; - Unix.bind s_ip (Unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) ; - Unix.listen s_ip 5 ; - let port = - match Unix.getsockname s_ip with - | Unix.ADDR_INET (_, port) -> - port - | _ -> - assert false - in - let s_unix = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - to_close := s_unix :: !to_close ; - let path = Filename.temp_file "channel" "" in - to_unlink := path :: !to_unlink ; - if Sys.file_exists path then Unix.unlink path ; - Unix.bind s_unix (Unix.ADDR_UNIX path) ; - Unix.listen s_unix 5 ; - let token = "token" in - let protocols = - let open Xcp_channel_protocol in - [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] - in - (* We need to hang onto a copy of the proxy_socket so we can run a proxy - in a background thread, allowing the caller to close their copy. *) - let proxy_socket = Unix.dup proxy_socket in - to_close := proxy_socket :: !to_close ; - let (_ : Thread.t) = - Thread.create - (fun (fds, paths) -> - (* The thread takes over management of the listening sockets *) - let to_close = ref fds in - let to_unlink = ref paths in - let close fd = - if List.mem fd !to_close then ( - to_close := List.filter (fun x -> x <> fd) !to_close ; - Unix.close fd - ) - in - finally - (fun () -> - let readable, _, _ = Unix.select [s_ip; s_unix] [] [] (-1.0) in - if List.mem s_unix readable then ( - let fd, _peer = Unix.accept s_unix in - to_close := fd :: !to_close ; - let buffer = Bytes.make (String.length token) '\000' in - let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in - let token' = Bytes.sub_string buffer 0 n in - if token = token' then - let (_ : int) = - Fd_send_recv.send_fd_substring fd token 0 - (String.length token) [] proxy_socket - in - () - ) else if List.mem s_ip readable then ( - let fd, _peer = Unix.accept s_ip in - List.iter close !to_close ; - to_close := fd :: !to_close ; - proxy fd proxy_socket - ) else - assert false - (* can never happen *) - ) - (fun () -> - List.iter close !to_close ; - List.iter Unix.unlink !to_unlink - ) - ) - (!to_close, !to_unlink) - in - (* Handover of listening sockets successful *) - to_close := [] ; - to_unlink := [] ; - protocols - ) - (fun () -> - List.iter Unix.close !to_close ; - List.iter Unix.unlink !to_unlink - ) - -let receive protocols = - let open Xcp_channel_protocol in - let weight = function - | TCP_proxy (_, _) -> - 2 - | Unix_sendmsg (domid, _, _) -> - if my_domid = domid then 3 else 0 - | V4V_proxy (_, _) -> - 0 - in - let protocol = - match List.sort (fun a b -> compare (weight b) (weight a)) protocols with - | [] -> - raise Channel_setup_failed - | best :: _ -> - if weight best = 0 then raise Channel_setup_failed else best - in - match protocol with - | V4V_proxy (_, _) -> - assert false (* weight is 0 above *) - | TCP_proxy (ip, port) -> ( - let unwrapped_ip = Scanf.ksscanf ip (fun _ _ -> ip) "[%s@]" Fun.id in - let addr = Unix.ADDR_INET (Unix.inet_addr_of_string unwrapped_ip, port) in - let family = Unix.domain_of_sockaddr addr in - let s = Unix.socket family Unix.SOCK_STREAM 0 in - try Unix.connect s addr ; s with e -> Unix.close s ; raise e - ) - | Unix_sendmsg (_, path, token) -> - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - finally - (fun () -> - Unix.connect s (Unix.ADDR_UNIX path) ; - let (_ : int) = - Unix.send_substring s token 0 (String.length token) [] - in - let buf = Bytes.create (String.length token) in - let _, _, fd = Fd_send_recv.recv_fd s buf 0 (Bytes.length buf) [] in - fd - ) - (fun () -> Unix.close s) diff --git a/ocaml/xapi-idl/lib/posix_channel.mli b/ocaml/xapi-idl/lib/posix_channel.mli deleted file mode 100644 index 8610f27a86d..00000000000 --- a/ocaml/xapi-idl/lib/posix_channel.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* - * Copyright (C) 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. - *) - -val send : Unix.file_descr -> Xcp_channel_protocol.t list -(** [send fd] attempts to send the channel represented by [fd] to a remote - process. Note the file descriptor remains open in the original process and - should still be closed normally. *) - -val receive : Xcp_channel_protocol.t list -> Unix.file_descr -(** [receive protocols] receives a channel from a remote. *) diff --git a/ocaml/xapi-idl/lib/scheduler.ml b/ocaml/xapi-idl/lib/scheduler.ml index 407120c9fc6..e46a0fdbd29 100644 --- a/ocaml/xapi-idl/lib/scheduler.ml +++ b/ocaml/xapi-idl/lib/scheduler.ml @@ -18,33 +18,7 @@ open D let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute -module PipeDelay = struct - (* Concrete type is the ends of a pipe *) - type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - pipe_out: Unix.file_descr - ; pipe_in: Unix.file_descr - } - - let make () = - let pipe_out, pipe_in = Unix.pipe () in - {pipe_out; pipe_in} - - let wait (x : t) (seconds : float) = - let timeout = if seconds < 0.0 then 0.0 else seconds in - if Thread.wait_timed_read x.pipe_out timeout then - (* flush the single byte from the pipe *) - let (_ : int) = Unix.read x.pipe_out (Bytes.create 1) 0 1 in - (* return false if we were woken *) - false - else - (* return true if we waited the full length of time, false if we were woken *) - true - - let signal (x : t) = - let (_ : int) = Unix.write x.pipe_in (Bytes.of_string "X") 0 1 in - () -end +module PipeDelay = Xapi_stdext_threads.Threadext.Delay type handle = Mtime.span * int @@ -67,7 +41,7 @@ module HandleMap = Map.Make (struct c end) -type item = {id: int; name: string; fn: unit -> unit} +type item = {name: string; fn: unit -> unit} type t = { mutable schedule: item HandleMap.t @@ -114,7 +88,7 @@ let one_shot_f s dt (name : string) f = with_lock s.m (fun () -> let id = s.next_id in s.next_id <- s.next_id + 1 ; - let item = {id; name; fn= f} in + let item = {name; fn= f} in let handle = (time, id) in s.schedule <- HandleMap.add handle item s.schedule ; PipeDelay.signal s.delay ; diff --git a/ocaml/xapi-idl/lib/task_server.ml b/ocaml/xapi-idl/lib/task_server.ml index 32c29e0f976..0053015387d 100644 --- a/ocaml/xapi-idl/lib/task_server.ml +++ b/ocaml/xapi-idl/lib/task_server.ml @@ -101,14 +101,12 @@ functor task_map: task_handle SMap.t ref ; mutable test_cancel_trigger: (string * int) option ; m: Mutex.t - ; c: Condition.t } let empty () = let task_map = ref SMap.empty in let m = Mutex.create () in - let c = Condition.create () in - {task_map; test_cancel_trigger= None; m; c} + {task_map; test_cancel_trigger= None; m} (* [next_task_id ()] returns a fresh task id *) let next_task_id = diff --git a/ocaml/xapi-idl/lib/xcp_channel.ml b/ocaml/xapi-idl/lib/xcp_channel.ml deleted file mode 100644 index 395da851a5f..00000000000 --- a/ocaml/xapi-idl/lib/xcp_channel.ml +++ /dev/null @@ -1,17 +0,0 @@ -type t = Unix.file_descr - -let file_descr_of_t t = t - -let t_of_file_descr t = t - -[@@@ocaml.warning "-34"] - -type protocols = Xcp_channel_protocol.t list [@@deriving rpc] - -let rpc_of_t fd = - let protocols = Posix_channel.send fd in - rpc_of_protocols protocols - -let t_of_rpc x = - let protocols = protocols_of_rpc x in - Posix_channel.receive protocols diff --git a/ocaml/xapi-idl/lib/xcp_channel.mli b/ocaml/xapi-idl/lib/xcp_channel.mli deleted file mode 100644 index 35849a1e5d4..00000000000 --- a/ocaml/xapi-idl/lib/xcp_channel.mli +++ /dev/null @@ -1,13 +0,0 @@ -type t - -val rpc_of_t : t -> Rpc.t - -val t_of_rpc : Rpc.t -> t - -val file_descr_of_t : t -> Unix.file_descr - -val t_of_file_descr : Unix.file_descr -> t - -val protocols_of_rpc : Rpc.t -> Xcp_channel_protocol.t list - -val rpc_of_protocols : Xcp_channel_protocol.t list -> Rpc.t diff --git a/ocaml/xapi-idl/lib_test/channel_test.ml b/ocaml/xapi-idl/lib_test/channel_test.ml deleted file mode 100644 index dd607935778..00000000000 --- a/ocaml/xapi-idl/lib_test/channel_test.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* - * Copyright (C) 2011-2013 Citrix 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 dup_automatic x = - let x = Xcp_channel.t_of_file_descr x in - let y = Xcp_channel.rpc_of_t x in - let z = Xcp_channel.t_of_rpc y in - Xcp_channel.file_descr_of_t z - -let dup_sendmsg x = - let protos = Posix_channel.send x in - let proto = - List.find - (function - | Xcp_channel_protocol.Unix_sendmsg (_, _, _) -> true | _ -> false - ) - protos - in - Posix_channel.receive [proto] - -let count_fds () = Array.length (Sys.readdir "/proc/self/fd") - -(* dup stdout, check /proc/pid/fd *) -let check_for_leak dup_function () = - let before = count_fds () in - let stdout2 = dup_function Unix.stdout in - let after = count_fds () in - Alcotest.(check int) "fds" (before + 1) after ; - Unix.close stdout2 ; - let after' = count_fds () in - Alcotest.(check int) "fds" before after' - -let dup_proxy x = - let protos = Posix_channel.send x in - let proto = - List.find - (function - | Xcp_channel_protocol.TCP_proxy (_ip, _port) -> true | _ -> false - ) - protos - in - Posix_channel.receive [proto] - -let check_for_leak_proxy () = - let a, _b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - let before = count_fds () in - let c = dup_proxy a in - (* background fd closing *) - Thread.delay 1.0 ; - let after = count_fds () in - Alcotest.(check int) "fds" (before + 2) after ; - Unix.close c ; - (* background fd closing *) - Thread.delay 1.0 ; - let after' = count_fds () in - Alcotest.(check int) "fds" before after' - -let tests = - [ - ( "check_for_leak with automatic selection" - , `Quick - , check_for_leak dup_automatic - ) - ; ("check_for_leak with sendmsg", `Quick, check_for_leak dup_sendmsg) - ; ("check_for_leak_proxy", `Quick, check_for_leak_proxy) - ] diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index 57c8c95e592..0806453c035 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -50,4 +50,4 @@ xapi-idl.xen.interface.types xapi-log ) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Task_server_test Updates_test)))) diff --git a/ocaml/xapi-idl/misc/channel_helper.ml b/ocaml/xapi-idl/misc/channel_helper.ml deleted file mode 100644 index 1485e6a5ead..00000000000 --- a/ocaml/xapi-idl/misc/channel_helper.ml +++ /dev/null @@ -1,221 +0,0 @@ -let project_url = "https://github.com/xen-org/xcp-idl" - -open Lwt - -let my_domid = 0 (* TODO: figure this out *) - -exception Short_write of int * int - -exception End_of_file - -let copy_all src dst = - let buffer = Bytes.make 16384 '\000' in - let rec loop () = - Lwt_unix.read src buffer 0 (Bytes.length buffer) >>= fun n -> - if n = 0 then - Lwt.fail End_of_file - else - Lwt_unix.write dst buffer 0 n >>= fun m -> - if n <> m then Lwt.fail (Short_write (m, n)) else loop () - in - loop () - -let proxy a b = - let copy _id src dst = - Lwt.catch - (fun () -> copy_all src dst) - (fun _e -> - (try Lwt_unix.shutdown src Lwt_unix.SHUTDOWN_RECEIVE with _ -> ()) ; - (try Lwt_unix.shutdown dst Lwt_unix.SHUTDOWN_SEND with _ -> ()) ; - return () - ) - in - let ts = [copy "ab" a b; copy "ba" b a] in - Lwt.join ts - -let file_descr_of_int (x : int) : Unix.file_descr = Obj.magic x - -(* Keep this in sync with ocaml's file_descr type *) - -let ip = ref "127.0.0.1" - -let unix = ref "/tmp" - -module Common = struct - type t = {verbose: bool; debug: bool; port: int} [@@deriving rpc] - - let make verbose debug port = {verbose; debug; port} -end - -let _common_options = "COMMON OPTIONS" - -open Cmdliner - -(* Options common to all commands *) -let common_options_t = - let docs = _common_options in - let debug = - let doc = "Give only debug output." in - Arg.(value & flag & info ["debug"] ~docs ~doc) - in - let verb = - let doc = "Give verbose output." in - let verbose = (true, Arg.info ["v"; "verbose"] ~docs ~doc) in - Arg.(last & vflag_all [false] [verbose]) - in - let port = - let doc = Printf.sprintf "Specify port to connect to the message switch." in - Arg.(value & opt int 8080 & info ["port"] ~docs ~doc) - in - Term.(const Common.make $ debug $ verb $ port) - -(* Help sections common to all commands *) -let help = - [ - `S _common_options - ; `P "These options are common to all commands." - ; `S "MORE HELP" - ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command." - ; `Noblank - ; `S "BUGS" - ; `P (Printf.sprintf "Check bug reports at %s" project_url) - ] - -(* Commands *) -let advertise_t _common_options_t proxy_socket = - let unwrapped_ip = Scanf.ksscanf !ip (fun _ _ -> !ip) "[%s@]" Fun.id in - let addr = Lwt_unix.ADDR_INET (Unix.inet_addr_of_string unwrapped_ip, 0) in - let family = Unix.domain_of_sockaddr addr in - let s_ip = Lwt_unix.socket family Lwt_unix.SOCK_STREAM 0 in - (* INET socket, can't block *) - Lwt_unix.bind s_ip addr >>= fun () -> - Lwt_unix.listen s_ip 5 ; - let port = - match Lwt_unix.getsockname s_ip with - | Unix.ADDR_INET (_, port) -> - port - | _ -> - assert false - in - let s_unix = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in - (* Try to avoid polluting the filesystem with unused unix domain sockets *) - let path = - Printf.sprintf "%s/%s.%d" !unix - (Filename.basename Sys.argv.(0)) - (Unix.getpid ()) - in - if Sys.file_exists path then Unix.unlink path ; - Lwt_unix.bind s_unix (Lwt_unix.ADDR_UNIX path) >>= fun () -> - List.iter - (fun signal -> - ignore (Lwt_unix.on_signal signal (fun _ -> Unix.unlink path ; exit 1)) - ) - [Sys.sigterm; Sys.sigint] ; - Lwt_unix.listen s_unix 5 ; - let token = "token" in - let protocols = - let open Xcp_channel_protocol in - [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] - in - Printf.fprintf stdout "%s\n%!" - (Jsonrpc.to_string (Xcp_channel.rpc_of_protocols protocols)) ; - let t_ip = - Lwt_unix.accept s_ip >>= fun (fd, _peer) -> - Lwt_unix.close s_ip >>= fun () -> - proxy fd (Lwt_unix.of_unix_file_descr proxy_socket) - in - let t_unix = - Lwt_unix.accept s_unix >>= fun (fd, _peer) -> - let buffer = Bytes.make (String.length token) '\000' in - let io_vector = Lwt_unix.IO_vectors.create () in - Lwt_unix.IO_vectors.append_bytes io_vector buffer 0 (Bytes.length buffer) ; - Lwt_unix.recv_msg ~socket:fd ~io_vectors:io_vector >>= fun (n, fds) -> - List.iter Unix.close fds ; - let token' = Bytes.sub buffer 0 n in - let io_vector' = Lwt_unix.IO_vectors.create () in - Lwt_unix.IO_vectors.append_bytes io_vector' token' 0 (Bytes.length token') ; - if token = Bytes.to_string token' then - Lwt_unix.send_msg ~socket:fd ~io_vectors:io_vector' ~fds:[proxy_socket] - >>= fun _ -> return () - else - return () - in - Lwt.pick [t_ip; t_unix] >>= fun () -> Unix.unlink path ; return () - -let advertise common_options_t fd = - match fd with - | Some x -> - Lwt_main.run (advertise_t common_options_t (file_descr_of_int x)) ; - `Ok () - | None -> - `Error (true, "you must provide a file descriptor to proxy") - -let advertise_cmd = - let doc = "advertise a given channel represented as a file-descriptor" in - let man = - [ - `S "DESCRIPTION" - ; `P - "Advertises a given channel over as many protocols as possible, and \ - waits for someone to connect." - ] - @ help - in - let fd = - let doc = Printf.sprintf "File descriptor to advertise" in - Arg.(value & pos 0 (some int) None & info [] ~docv:"FD" ~doc) - in - Cmd.v - (Cmd.info "advertise" ~sdocs:_common_options ~doc ~man) - Term.(ret (const advertise $ common_options_t $ fd)) - -let connect_t _common_options_t = - (Lwt_io.read_line_opt Lwt_io.stdin >>= function - | None -> - return "" - | Some x -> - return x - ) - >>= fun advertisement -> - let open Xcp_channel in - let fd = - Lwt_unix.of_unix_file_descr - (file_descr_of_t (t_of_rpc (Jsonrpc.of_string advertisement))) - in - let a = copy_all Lwt_unix.stdin fd in - let b = copy_all fd Lwt_unix.stdout in - Lwt.join [a; b] - -let connect common_options_t = - Lwt_main.run (connect_t common_options_t) ; - `Ok () - -let connect_cmd = - let doc = "connect to a channel and proxy to the terminal" in - let man = - [ - `S "DESCRIPTION" - ; `P - "Connect to a channel which has been advertised and proxy I/O to the \ - console. The advertisement will be read from stdin as a single line \ - of text." - ] - @ help - in - Cmd.v - (Cmd.info "connect" ~sdocs:_common_options ~doc ~man) - Term.(ret (const connect $ common_options_t)) - -let cmds = [advertise_cmd; connect_cmd] - -let () = - let default = - Term.(ret (const (fun _ -> `Help (`Pager, None)) $ common_options_t)) - in - let info = - let doc = "channel (file-descriptor) passing helper program" in - let man = help in - Cmd.info "proxy" ~version:"1.0.0" ~sdocs:_common_options ~doc ~man - in - let cmd = Cmd.group ~default info cmds in - exit (Cmd.eval cmd) diff --git a/ocaml/xapi-idl/misc/dune b/ocaml/xapi-idl/misc/dune deleted file mode 100644 index 9d009d01260..00000000000 --- a/ocaml/xapi-idl/misc/dune +++ /dev/null @@ -1,16 +0,0 @@ -(executable - (name channel_helper) - (public_name xcp-idl-debugger) - (modules channel_helper) - (package xapi-idl) - (libraries - cmdliner - dune-build-info - lwt - lwt.unix - rpclib.core - rpclib.json - xapi-idl - xapi-log - ) - (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-idl/network/dune b/ocaml/xapi-idl/network/dune index eb321c114e3..a9a4869945d 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -21,7 +21,7 @@ (modules network_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/rrd/dune b/ocaml/xapi-idl/rrd/dune index 7a407a77e9d..9462c9341e6 100644 --- a/ocaml/xapi-idl/rrd/dune +++ b/ocaml/xapi-idl/rrd/dune @@ -50,7 +50,7 @@ (modes exe) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/storage/dune b/ocaml/xapi-idl/storage/dune index 500a6f5bbfd..05f146429bc 100644 --- a/ocaml/xapi-idl/storage/dune +++ b/ocaml/xapi-idl/storage/dune @@ -54,7 +54,7 @@ (libraries alcotest cmdliner - dune-build-info + xapi-idl xapi-idl.storage xapi-idl.storage.interface @@ -67,7 +67,7 @@ (modules suite vdi_automaton_test) (libraries alcotest - dune-build-info + xapi-idl.storage.interface xapi-idl.storage.interface.types ) diff --git a/ocaml/xapi-idl/v6/dune b/ocaml/xapi-idl/v6/dune index 059bf6fc181..79751c08794 100644 --- a/ocaml/xapi-idl/v6/dune +++ b/ocaml/xapi-idl/v6/dune @@ -19,7 +19,7 @@ (modules v6_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-storage-cli/dune b/ocaml/xapi-storage-cli/dune index d64138c29df..624f2f727e1 100644 --- a/ocaml/xapi-storage-cli/dune +++ b/ocaml/xapi-storage-cli/dune @@ -1,7 +1,7 @@ (executable (name main) (libraries - dune-build-info + xapi-idl xapi-idl.storage xapi-idl.storage.interface diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index c137849c72e..e27762a2963 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -10,7 +10,7 @@ core core_unix core_unix.time_unix - dune-build-info + message-switch-async message-switch-unix result diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 2c904af7a43..b9542fd1963 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1693,6 +1693,10 @@ let rec diff a b = | a :: aa -> if List.mem b a ~equal:String.( = ) then diff aa b else a :: diff aa b +(* default false due to bugs in SMAPIv3 plugins, + once they are fixed this should be set to true *) +let concurrent = ref false + let watch_volume_plugins ~volume_root ~switch_path ~pipe = let create volume_plugin_name = if Hashtbl.mem servers volume_plugin_name then @@ -1700,7 +1704,9 @@ let watch_volume_plugins ~volume_root ~switch_path ~pipe = else ( info "Adding %s" volume_plugin_name ; let volume_script_dir = Filename.concat volume_root volume_plugin_name in - Message_switch_async.Protocol_async.Server.listen + Message_switch_async.Protocol_async.Server.( + if !concurrent then listen_p else listen + ) ~process:(process_smapiv2_requests (bind ~volume_script_dir)) ~switch:switch_path ~queue:(Filename.basename volume_plugin_name) @@ -1957,6 +1963,11 @@ let _ = , (fun () -> string_of_bool !self_test_only) , "Do only a self-test and exit" ) + ; ( "concurrent" + , Arg.Set concurrent + , (fun () -> string_of_bool !concurrent) + , "Issue SMAPIv3 calls concurrently" + ) ] in configure2 ~name:"xapi-script-storage" ~version:Xapi_version.version diff --git a/ocaml/xapi-storage/generator/lib/dune b/ocaml/xapi-storage/generator/lib/dune index 85595a96131..e8a47976976 100644 --- a/ocaml/xapi-storage/generator/lib/dune +++ b/ocaml/xapi-storage/generator/lib/dune @@ -2,7 +2,8 @@ (name xapi_storage) (public_name xapi-storage) (modules apis common control data files plugin task) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module + ((pps ppx_deriving_rpc) Common Control Data Plugin Task))) (libraries result rpclib.core diff --git a/ocaml/xapi-types/dune b/ocaml/xapi-types/dune index da88000af95..3fb8e0711b1 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -21,9 +21,8 @@ xapi-consts xapi-stdext-date xapi-stdext-unix - xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) API Event_types Features SecretString))) ) diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index c5870d8555f..ba95fbe03d9 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -1,197 +1,6 @@ -(* - * 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. - *) -(** The main callback function. - - @group API Messaging -*) - -(** Actions module *) -module Actions = struct - (** The DebugVersion throws a NotImplemented exception for everything - by default. The ReleaseVersion is missing all the fields; - so server will not compile unless everything is overridden *) - - module Task = Xapi_task - module Session = Xapi_session - module Auth = Xapi_auth - module Subject = Xapi_subject - module Role = Xapi_role - module Event = Xapi_event - module Alert = Xapi_alert - - module VM = struct include Xapi_vm include Xapi_vm_migrate end - - module VM_metrics = struct end - - module VM_guest_metrics = struct end - - module VMPP = Xapi_vmpp - module VMSS = Xapi_vmss - module VM_appliance = Xapi_vm_appliance - module VM_group = Xapi_vm_group - module DR_task = Xapi_dr_task - - module LVHD = struct end - - module Host = Xapi_host - module Host_crashdump = Xapi_host_crashdump - module Pool = Xapi_pool - module Pool_update = Xapi_pool_update - module Pool_patch = Xapi_pool_patch - module Host_patch = Xapi_host_patch - - module Host_metrics = struct end - - module Host_cpu = struct end - - module Network = Xapi_network - module VIF = Xapi_vif - - module VIF_metrics = struct end - - module PIF = Xapi_pif - - module PIF_metrics = struct end - - module SR = Xapi_sr - module SM = Xapi_sm - - module VDI = struct - include Xapi_vdi - - let pool_migrate = Xapi_vm_migrate.vdi_pool_migrate - end - - module VBD = Xapi_vbd - - module VBD_metrics = struct end - - module Crashdump = Xapi_crashdump - module PBD = Xapi_pbd - - module Data_source = struct end - - module VTPM = Xapi_vtpm - - let not_implemented x = - raise (Api_errors.Server_error (Api_errors.not_implemented, [x])) - - module Console = struct - let create ~__context ~other_config:_ = not_implemented "Console.create" - - let destroy ~__context ~self:_ = not_implemented "Console.destroy" - end - - module Bond = Xapi_bond - module VLAN = Xapi_vlan - module User = Xapi_user - module Blob = Xapi_blob - module Message = Xapi_message - module Secret = Xapi_secret - module Tunnel = Xapi_tunnel - module PCI = Xapi_pci - module PGPU = Xapi_pgpu - module GPU_group = Xapi_gpu_group - module VGPU = Xapi_vgpu - module VGPU_type = Xapi_vgpu_type - module PVS_site = Xapi_pvs_site - module PVS_server = Xapi_pvs_server - module PVS_proxy = Xapi_pvs_proxy - module PVS_cache_storage = Xapi_pvs_cache_storage - - module Feature = struct end - - module SDN_controller = Xapi_sdn_controller - - module Vdi_nbd_server_info = struct end - - module Probe_result = struct end - - module Sr_stat = struct end - - module PUSB = Xapi_pusb - module USB_group = Xapi_usb_group - module VUSB = Xapi_vusb - module Network_sriov = Xapi_network_sriov - module Cluster = Xapi_cluster - module Cluster_host = Xapi_cluster_host - module Certificate = Certificates - module Diagnostics = Xapi_diagnostics - module Repository = Repository - module Observer = Xapi_observer -end - -(** Use the server functor to make an XML-RPC dispatcher. *) -module Forwarder = Message_forwarding.Forward (Actions) - +open Api_server_common module Server = Server.Make (Actions) (Forwarder) -(** Here are the functions to forward calls made on the unix domain socket on a slave to a master *) -module D = Debug.Make (struct - let name = "api_server" -end) - -(** Forward a call to the master *) -let forward req call is_json = - let open Xmlrpc_client in - let transport = - SSL - ( SSL.make ~use_stunnel_cache:true ~verify_cert:(Stunnel_client.pool ()) () - , Pool_role.get_master_address () - , !Constants.https_port - ) - in - let rpc = if is_json then JSONRPC_protocol.rpc else XMLRPC_protocol.rpc in - rpc ~srcstr:"xapi" ~dststr:"xapi" ~transport - ~http:{req with Http.Request.frame= true} - call - -(* Whitelist of functions that do *not* get forwarded to the master (e.g. session.login_with_password) *) -(* !!! Note, this only blocks synchronous calls. As is it happens, all the calls we want to block right now are only - synchronous. However, we'd probably want to change this is the list starts getting longer. *) -let whitelist = - List.map - (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) - Datamodel.whitelist - -let emergency_call_list = - List.map - (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) - Datamodel.emergency_calls - -let is_himn_req req = - match req.Http.Request.host with - | Some h -> ( - match Xapi_mgmt_iface.himn_addr () with - | Some himn -> - himn = h - | None -> - false - ) - | None -> - false - -(* The API does not use the error.code and only retains it for compliance with - the JSON-RPC v2.0 specs. We set this always to a non-zero value because - some JsonRpc clients consider error.code 0 as no error*) -let error_code_lit = 1L - -let json_of_error_object ?(data = None) code message = - let data_json = match data with Some d -> [("data", d)] | None -> [] in - Rpc.Dict - ([("code", Rpc.Int code); ("message", Rpc.String message)] @ data_json) - (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = (* We now have the body string, the xml and the call name, and can also tell *) @@ -274,8 +83,6 @@ let create_thumbprint_header req response = [(!Xapi_globs.cert_thumbprint_header_response, x)] ) -module Unixext = Xapi_stdext_unix.Unixext - (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req bio _ = let fd = Buf_io.fd_of bio in diff --git a/ocaml/xapi/api_server_common.ml b/ocaml/xapi/api_server_common.ml new file mode 100644 index 00000000000..1cd1758a078 --- /dev/null +++ b/ocaml/xapi/api_server_common.ml @@ -0,0 +1,195 @@ +(* + * 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. + *) +(** The main callback function. + + @group API Messaging +*) + +(** Actions module *) +module Actions = struct + (** The DebugVersion throws a NotImplemented exception for everything + by default. The ReleaseVersion is missing all the fields; + so server will not compile unless everything is overridden *) + + module Task = Xapi_task + module Session = Xapi_session + module Auth = Xapi_auth + module Subject = Xapi_subject + module Role = Xapi_role + module Event = Xapi_event + module Alert = Xapi_alert + + module VM = struct include Xapi_vm include Xapi_vm_migrate end + + module VM_metrics = struct end + + module VM_guest_metrics = struct end + + module VMPP = Xapi_vmpp + module VMSS = Xapi_vmss + module VM_appliance = Xapi_vm_appliance + module VM_group = Xapi_vm_group + module DR_task = Xapi_dr_task + + module LVHD = struct end + + module Host = Xapi_host + module Host_crashdump = Xapi_host_crashdump + module Pool = Xapi_pool + module Pool_update = Xapi_pool_update + module Pool_patch = Xapi_pool_patch + module Host_patch = Xapi_host_patch + + module Host_metrics = struct end + + module Host_cpu = struct end + + module Network = Xapi_network + module VIF = Xapi_vif + + module VIF_metrics = struct end + + module PIF = Xapi_pif + + module PIF_metrics = struct end + + module SR = Xapi_sr + module SM = Xapi_sm + + module VDI = struct + include Xapi_vdi + + let pool_migrate = Xapi_vm_migrate.vdi_pool_migrate + end + + module VBD = Xapi_vbd + + module VBD_metrics = struct end + + module Crashdump = Xapi_crashdump + module PBD = Xapi_pbd + + module Data_source = struct end + + module VTPM = Xapi_vtpm + + let not_implemented x = + raise (Api_errors.Server_error (Api_errors.not_implemented, [x])) + + module Console = struct + let create ~__context ~other_config:_ = not_implemented "Console.create" + + let destroy ~__context ~self:_ = not_implemented "Console.destroy" + end + + module Bond = Xapi_bond + module VLAN = Xapi_vlan + module User = Xapi_user + module Blob = Xapi_blob + module Message = Xapi_message + module Secret = Xapi_secret + module Tunnel = Xapi_tunnel + module PCI = Xapi_pci + module PGPU = Xapi_pgpu + module GPU_group = Xapi_gpu_group + module VGPU = Xapi_vgpu + module VGPU_type = Xapi_vgpu_type + module PVS_site = Xapi_pvs_site + module PVS_server = Xapi_pvs_server + module PVS_proxy = Xapi_pvs_proxy + module PVS_cache_storage = Xapi_pvs_cache_storage + + module Feature = struct end + + module SDN_controller = Xapi_sdn_controller + + module Vdi_nbd_server_info = struct end + + module Probe_result = struct end + + module Sr_stat = struct end + + module PUSB = Xapi_pusb + module USB_group = Xapi_usb_group + module VUSB = Xapi_vusb + module Network_sriov = Xapi_network_sriov + module Cluster = Xapi_cluster + module Cluster_host = Xapi_cluster_host + module Certificate = Certificates + module Diagnostics = Xapi_diagnostics + module Repository = Repository + module Observer = Xapi_observer +end + +(** Use the server functor to make an XML-RPC dispatcher. *) +module Forwarder = Message_forwarding.Forward (Actions) + +(** Here are the functions to forward calls made on the unix domain socket on a slave to a master *) +module D = Debug.Make (struct + let name = "api_server" +end) + +(** Forward a call to the master *) +let forward req call is_json = + let open Xmlrpc_client in + let transport = + SSL + ( SSL.make ~use_stunnel_cache:true ~verify_cert:(Stunnel_client.pool ()) () + , Pool_role.get_master_address () + , !Constants.https_port + ) + in + let rpc = if is_json then JSONRPC_protocol.rpc else XMLRPC_protocol.rpc in + rpc ~srcstr:"xapi" ~dststr:"xapi" ~transport + ~http:{req with Http.Request.frame= true} + call + +(* Whitelist of functions that do *not* get forwarded to the master (e.g. session.login_with_password) *) +(* !!! Note, this only blocks synchronous calls. As is it happens, all the calls we want to block right now are only + synchronous. However, we'd probably want to change this is the list starts getting longer. *) +let whitelist = + List.map + (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) + Datamodel.whitelist + +let emergency_call_list = + List.map + (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) + Datamodel.emergency_calls + +let is_himn_req req = + match req.Http.Request.host with + | Some h -> ( + match Xapi_mgmt_iface.himn_addr () with + | Some himn -> + himn = h + | None -> + false + ) + | None -> + false + +(* The API does not use the error.code and only retains it for compliance with + the JSON-RPC v2.0 specs. We set this always to a non-zero value because + some JsonRpc clients consider error.code 0 as no error*) +let error_code_lit = 1L + +let json_of_error_object ?(data = None) code message = + let data_json = match data with Some d -> [("data", d)] | None -> [] in + Rpc.Dict + ([("code", Rpc.Int code); ("message", Rpc.String message)] @ data_json) + +(* debug(fmt "response = %s" response); *) + +module Unixext = Xapi_stdext_unix.Unixext diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index effb154877e..fe66194cb0e 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -19,8 +19,6 @@ module D = Debug.Make (struct let name = "certificates" end) open D -let () = Mirage_crypto_rng_unix.initialize () - (* Certificate locations: * a) stunnel external = /etc/xensource/xapi-ssl.pem * b) stunnel SNI (internal) = /etc/xensource/xapi-pool-tls.pem diff --git a/ocaml/xapi/create_misc.ml b/ocaml/xapi/create_misc.ml index 1b6e26ab84d..beb94f4751c 100644 --- a/ocaml/xapi/create_misc.ml +++ b/ocaml/xapi/create_misc.ml @@ -435,7 +435,8 @@ let create_root_user ~__context = Db.User.create ~__context ~ref ~fullname ~short_name ~uuid ~other_config:[] let get_xapi_verstring () = - Printf.sprintf "%d.%d" Constants.version_major Constants.version_minor + Printf.sprintf "%d.%d" Xapi_version.xapi_version_major + Xapi_version.xapi_version_minor (** Create assoc list of Supplemental-Pack information. * The package information is taking from the [XS-REPOSITORY] XML file in the package diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index a0442314448..2efe11b89ee 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -30,7 +30,8 @@ let use_host_heartbeat_for_liveness = ref true let use_host_heartbeat_for_liveness_m = Mutex.create () -let host_heartbeat_table : (API.ref_host, float) Hashtbl.t = Hashtbl.create 16 +let host_heartbeat_table : (API.ref_host, Clock.Timer.t) Hashtbl.t = + Hashtbl.create 16 let host_skew_table : (API.ref_host, float) Hashtbl.t = Hashtbl.create 16 @@ -77,45 +78,24 @@ let detect_clock_skew ~__context host skew = (* Master compares the database with the in-memory host heartbeat table and sets the live flag accordingly. Called with the use_host_heartbeat_for_liveness_m and use_host_heartbeat_for_liveness is true (ie non-HA mode) *) let check_host_liveness ~__context = - (* Check for rolling upgrade mode - if so, use host metrics for liveness else use hashtbl *) - let rum = - try Helpers.rolling_upgrade_in_progress ~__context with _ -> false - in (* CA-16351: when performing the initial GC pass on first boot there won't be a localhost *) let localhost = try Helpers.get_localhost ~__context with _ -> Ref.null in - (* Look for "true->false" transition on Host_metrics.live *) let check_host host = if host <> localhost then try let hmetric = Db.Host.get_metrics ~__context ~self:host in let live = Db.Host_metrics.get_live ~__context ~self:hmetric in - (* See if the host is using the new HB mechanism, if so we'll use that *) - let new_heartbeat_time = + let timer = with_lock host_table_m (fun () -> - Option.value - (Hashtbl.find_opt host_heartbeat_table host) - ~default:Clock.Date.(epoch |> to_unix_time) + match Hashtbl.find_opt host_heartbeat_table host with + | Some x -> + x + | None -> + Clock.Timer.start + ~duration:!Xapi_globs.host_assumed_dead_interval ) in - let old_heartbeat_time = - if - rum - && Xapi_version.platform_version () - <> Helpers.version_string_of ~__context (Helpers.LocalObject host) - then ( - debug - "Host %s considering using metrics last update time as heartbeat" - (Ref.string_of host) ; - Date.to_float - (Db.Host_metrics.get_last_updated ~__context ~self:hmetric) - ) else - 0.0 - in - (* Use whichever value is the most recent to determine host liveness *) - let host_time = max old_heartbeat_time new_heartbeat_time in - let now = Unix.gettimeofday () in - (* we can now compare 'host_time' with 'now' *) - if now -. host_time < !Xapi_globs.host_assumed_dead_interval then + if not (Clock.Timer.has_expired timer) then (* From the heartbeat PoV the host looks alive. We try to (i) minimise database sets; and (ii) avoid toggling the host back to live if it has been marked as shutting_down. *) with_lock Xapi_globs.hosts_which_are_shutting_down_m (fun () -> @@ -131,10 +111,14 @@ let check_host_liveness ~__context = ) ) else if live then ( + let host_name_label = Db.Host.get_name_label ~__context ~self:host in + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + let elapsed = Clock.Timer.elapsed timer in debug - "Assuming host is offline since the heartbeat/metrics haven't been \ - updated for %.2f seconds; setting live to false" - (now -. host_time) ; + "Assuming host '%s' (%s) is offline since the heartbeat hasn't \ + been updated for %s seconds; setting live to false" + host_name_label host_uuid + (Clock.Timer.span_to_s elapsed |> string_of_float) ; Db.Host_metrics.set_live ~__context ~self:hmetric ~value:false ; Xapi_host_helpers.update_allowed_operations ~__context ~self:host ) ; @@ -252,9 +236,10 @@ let tickle_heartbeat ~__context host stuff = let reason = Xapi_hooks.reason__clean_shutdown in if use_host_heartbeat_for_liveness then Xapi_host_helpers.mark_host_as_dead ~__context ~host ~reason - ) else + ) else ( + Hashtbl.replace host_heartbeat_table host + (Clock.Timer.start ~duration:!Xapi_globs.host_assumed_dead_interval) ; let now = Unix.gettimeofday () in - Hashtbl.replace host_heartbeat_table host now ; (* compute the clock skew for later analysis *) if List.mem_assoc _time stuff then try @@ -262,6 +247,7 @@ let tickle_heartbeat ~__context host stuff = let skew = abs_float (now -. slave) in Hashtbl.replace host_skew_table host skew with _ -> () + ) ) ; [] diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 22b37b509ac..aebdf144225 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -54,11 +54,51 @@ (package xapi) ) +(library + (name xapi_internal_minimal) + (modules context custom_actions xapi_globs server_helpers session_check rbac rbac_audit db_actions taskHelper eventgen locking_helpers exnHelper rbac_static xapi_role xapi_extensions db) + (modes best) + (wrapped false) + (libraries + http_lib + httpsvr + ipaddr + xapi-types + xapi_database + mtime + tracing + uuid + rpclib.core + threads.posix + fmt + clock + astring + stunnel + sexplib0 + sexplib + sexpr + forkexec + xapi-idl + xapi_aux + xapi-stdext-std + xapi-stdext-date + xapi-stdext-pervasives + xapi-backtrace + xapi-datamodel + xapi-consts + xapi_version + xapi-stdext-threads + xapi-stdext-unix + rpclib.xml + xapi-log) +) + (library (name xapi_internal) (wrapped false) (modes best) - (modules (:standard \ xapi_main)) + (modules (:standard \ + xapi_main server api_server xapi custom_actions context xapi_globs server_helpers session_check rbac rbac_audit rbac_static db_actions taskHelper eventgen locking_helpers exnHelper xapi_role xapi_extensions db)) (libraries angstrom astring @@ -82,7 +122,6 @@ message-switch-core message-switch-unix mirage-crypto - mirage-crypto-rng.unix mtime mtime.clock.os pam @@ -140,6 +179,7 @@ xapi-idl.memory xapi-idl.gpumon xapi-idl.updates + (re_export xapi_internal_minimal) xapi-inventory xapi-log xapi-open-uri @@ -154,6 +194,7 @@ xapi-stdext-zerocheck xapi-tracing xapi-tracing-export + xapi_version xapi-xenopsd xenstore_transport.unix xml-light2 @@ -162,7 +203,58 @@ yojson zstd ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv ppx_deriving.ord)) + (preprocess (per_module + ((pps ppx_sexp_conv) Cert_distrib) + ((pps ppx_deriving.ord) Xapi_observer_components) + ((pps ppx_deriving_rpc) + Config_file_sync Extauth_plugin_ADwinbind Importexport Sparse_dd_wrapper + Storage_migrate Storage_mux Storage_smapiv1_wrapper Stream_vdi + System_domains Xapi_psr Xapi_services Xapi_udhcpd))) +) + +(library + (name xapi_internal_server_only) + (modes best) + (modules server) + (libraries xapi_internal_minimal http_lib rpclib.core xapi-types xapi-log xapi-stdext-encodings xapi-consts xapi-backtrace xapi-stdext-date rpclib.json) + (wrapped false) +) + +(library + (name xapi_internal_server) + (modes best) + (wrapped false) + (modules api_server xapi) + (libraries + forkexec + http_lib + httpsvr + rpclib.core + rpclib.json + rpclib.xml + stunnel + threads.posix + xapi-backtrace + xapi-client + xapi-consts + xapi-datamodel + xapi_internal_minimal + xapi-idl + xapi-inventory + (re_export xapi_internal_server_only) + xapi-log + xapi-stdext-date + xapi-stdext-encodings + xapi-stdext-pervasives + xapi-stdext-std + xapi-stdext-threads + xapi-stdext-unix + xapi-types + xapi_aux + xapi-consts.xapi_version + xapi_cli_server + xapi_database + xapi_internal) ) (executable @@ -173,6 +265,8 @@ (modules xapi_main) (libraries xapi_internal + xapi_internal_server + xapi_internal_minimal xapi-idl xapi-log xapi-stdext-unix diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 6cb156d21ca..24589827bc8 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -829,7 +829,7 @@ let metadata_handler (req : Request.t) s _ = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ Http.Hdr.task_id ^ ": " ^ task_id - ; "Server: " ^ Constants.xapi_user_agent + ; "Server: " ^ Xapi_version.xapi_user_agent ; content_type ; "Content-Length: " ^ string_of_int content_length ; "Content-Disposition: attachment; filename=\"export.xva\"" @@ -944,7 +944,7 @@ let handler (req : Request.t) s _ = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ Http.Hdr.task_id ^ ": " ^ task_id - ; "Server: " ^ Constants.xapi_user_agent + ; "Server: " ^ Xapi_version.xapi_user_agent ; content_type ; "Content-Disposition: attachment; filename=\"export.xva\"" ] diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index 869aac2a5f0..b6f784dc55c 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -41,8 +41,8 @@ let rpc_of_version x = ; (_product_version, Rpc.String x.product_version) ; (_product_brand, Rpc.String x.product_brand) ; (_build_number, Rpc.String x.build_number) - ; (_xapi_major, Rpc.Int (Int64.of_int Constants.version_major)) - ; (_xapi_minor, Rpc.Int (Int64.of_int Constants.version_minor)) + ; (_xapi_major, Rpc.Int (Int64.of_int Xapi_version.xapi_version_major)) + ; (_xapi_minor, Rpc.Int (Int64.of_int Xapi_version.xapi_version_minor)) ; (_export_vsn, Rpc.Int (Int64.of_int Xapi_globs.export_vsn)) ] @@ -112,8 +112,8 @@ let this_version __context = ; product_version= Xapi_version.product_version () ; product_brand= Xapi_version.product_brand () ; build_number= Xapi_version.build_number () - ; xapi_vsn_major= Constants.version_major - ; xapi_vsn_minor= Constants.version_minor + ; xapi_vsn_major= Xapi_version.xapi_version_major + ; xapi_vsn_minor= Xapi_version.xapi_version_minor ; export_vsn= Xapi_globs.export_vsn } diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index ded1739f211..e0a064e520d 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -6756,3 +6756,33 @@ functor Xapi_pool_helpers.call_fn_on_slaves_then_master ~__context fn end end + +(* for unit tests *) +let register_callback_fns () = + let set_stunnelpid _task_opt pid = + Locking_helpers.Thread_state.acquired + (Locking_helpers.Process ("stunnel", pid)) + in + let unset_stunnelpid _task_opt pid = + Locking_helpers.Thread_state.released + (Locking_helpers.Process ("stunnel", pid)) + in + let stunnel_destination_is_ok addr = + Server_helpers.exec_with_new_task "check_stunnel_destination" + (fun __context -> + let hosts = + Db.Host.get_refs_where ~__context + ~expr:(Eq (Field "address", Literal addr)) + in + match hosts with + | [host] -> ( + try check_live ~__context host ; true with _ -> false + ) + | _ -> + true + ) + in + Xmlrpc_client.Internal.set_stunnelpid_callback := Some set_stunnelpid ; + Xmlrpc_client.Internal.unset_stunnelpid_callback := Some unset_stunnelpid ; + Xmlrpc_client.Internal.destination_is_ok := Some stunnel_destination_is_ok ; + TaskHelper.init () diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index 68b04862f73..a824f77f23a 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -51,61 +51,72 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = debug "put_rrd_forwarder: start" ; let query = req.Http.Request.query in req.Http.Request.close <- true ; - let vm_uuid = List.assoc "uuid" query in - if (not (List.mem_assoc "ref" query)) && not (List.mem_assoc "uuid" query) - then - fail_req_with s "get_vm_rrd: missing the 'uuid' parameter" - Http.http_400_badrequest - else if Rrdd.has_vm_rrd vm_uuid then - ignore - (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path) - else - Xapi_http.with_context ~dummy:true "Get VM RRD." req s (fun __context -> - let open Http.Request in - (* List of possible actions. *) - let read_at_owner owner = - let address = Db.Host.get_address ~__context ~self:owner in - let url = make_url ~address ~req in - Http_svr.headers s (Http.http_302_redirect url) - in - let unarchive_at_master () = - let address = Pool_role.get_master_address () in - let query = (Constants.rrd_unarchive, "") :: query in - let url = make_url_from_query ~address ~uri:req.uri ~query in - Http_svr.headers s (Http.http_302_redirect url) - in - let unarchive () = - let req = {req with uri= Constants.rrd_unarchive_uri} in - ignore - (Xapi_services.hand_over_connection req s - !Rrd_interface.forwarded_path - ) - in - (* List of conditions involved. *) - let is_unarchive_request = - List.mem_assoc Constants.rrd_unarchive query + match List.assoc_opt "uuid" query with + | None -> + fail_req_with s "get_vm_rrd: missing the 'uuid' parameter" + Http.http_400_badrequest + | Some vm_uuid when Rrdd.has_vm_rrd vm_uuid -> + ignore + (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path) + | Some vm_uuid -> ( + Xapi_http.with_context ~dummy:true "Get VM RRD." req s @@ fun __context -> + (* List of possible actions. *) + let read_at address = + let url = make_url ~address ~req in + Http_svr.headers s (Http.http_302_redirect url) + in + let unarchive_at address = + let query = (Constants.rrd_unarchive, "") :: query in + let url = make_url_from_query ~address ~uri:req.uri ~query in + Http_svr.headers s (Http.http_302_redirect url) + in + let unarchive () = + let req = {req with m= Post; uri= Constants.rrd_unarchive_uri} in + ignore + (Xapi_services.hand_over_connection req s + !Rrd_interface.forwarded_path + ) + in + let unavailable () = + Http_svr.headers s (Http.http_503_service_unavailable ()) + in + (* List of conditions involved. *) + let is_unarchive_request = List.mem_assoc Constants.rrd_unarchive query in + let metrics_at () = + let ( let* ) = Option.bind in + let owner_of vm = + let owner = Db.VM.get_resident_on ~__context ~self:vm in + let is_xapi_initialising = List.mem_assoc "dbsync" query in + let is_available = not is_xapi_initialising in + if Db.is_valid_ref __context owner && is_available then + Some owner + else + None in - let is_master = Pool_role.is_master () in - let is_owner_online owner = Db.is_valid_ref __context owner in - let is_xapi_initialising = List.mem_assoc "dbsync" query in - (* The logic. *) - if is_unarchive_request then - unarchive () + let* owner = owner_of (Db.VM.get_by_uuid ~__context ~uuid:vm_uuid) in + let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in + if owner_uuid = Helpers.get_localhost_uuid () then + (* VM is local but metrics aren't available *) + None else - let localhost_uuid = Helpers.get_localhost_uuid () in - let vm_ref = Db.VM.get_by_uuid ~__context ~uuid:vm_uuid in - let owner = Db.VM.get_resident_on ~__context ~self:vm_ref in - let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in - let is_owner_localhost = owner_uuid = localhost_uuid in - if is_owner_localhost then - if is_master then - unarchive () - else - unarchive_at_master () - else if is_owner_online owner && not is_xapi_initialising then - read_at_owner owner - else - unarchive_at_master () + let address = Db.Host.get_address ~__context ~self:owner in + Some address + in + (* The logic. *) + if is_unarchive_request then + unarchive () + else + match (Pool_role.get_role (), metrics_at ()) with + | (Master | Slave _), Some owner -> + read_at owner + | Master, None -> + unarchive () + | Slave coordinator, None -> + unarchive_at coordinator + | Broken, _ -> + info "%s: host is broken, VM's metrics are not available" + __FUNCTION__ ; + unavailable () ) (* Forward the request for host RRD data to the RRDD HTTP handler. If the host diff --git a/ocaml/xapi/server.mli b/ocaml/xapi/server.mli new file mode 100644 index 00000000000..2f093e9adb6 --- /dev/null +++ b/ocaml/xapi/server.mli @@ -0,0 +1,7 @@ +module Make : functor + (_ : Custom_actions.CUSTOM_ACTIONS) + (_ : Custom_actions.CUSTOM_ACTIONS) + -> sig + val dispatch_call : + Http.Request.t -> Unix.file_descr -> Rpc.call -> Rpc.response +end diff --git a/ocaml/xapi/system_status.ml b/ocaml/xapi/system_status.ml index 1c564d541e8..bcbd0298d9c 100644 --- a/ocaml/xapi/system_status.ml +++ b/ocaml/xapi/system_status.ml @@ -52,7 +52,7 @@ let send_via_fd __context s entries output = let headers = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ - "Server: " ^ Constants.xapi_user_agent + "Server: " ^ Xapi_version.xapi_user_agent ; Http.Hdr.content_type ^ ": " ^ content_type ; "Content-Disposition: attachment; filename=\"system_status.tgz\"" ] diff --git a/ocaml/xapi/vgpuops.ml b/ocaml/xapi/vgpuops.ml index c55c46df226..284916182ce 100644 --- a/ocaml/xapi/vgpuops.ml +++ b/ocaml/xapi/vgpuops.ml @@ -20,8 +20,6 @@ open Xapi_stdext_std.Xstringext type vgpu_t = { vgpu_ref: API.ref_VGPU ; gpu_group_ref: API.ref_GPU_group - ; devid: int - ; other_config: (string * string) list ; type_ref: API.ref_VGPU_type ; requires_passthrough: [`PF | `VF] option } @@ -31,8 +29,6 @@ let vgpu_of_ref ~__context vgpu = { vgpu_ref= vgpu ; gpu_group_ref= vgpu_r.API.vGPU_GPU_group - ; devid= int_of_string vgpu_r.API.vGPU_device - ; other_config= vgpu_r.API.vGPU_other_config ; type_ref= vgpu_r.API.vGPU_type ; requires_passthrough= Xapi_vgpu.requires_passthrough ~__context ~self:vgpu } diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 0b1c213e993..26659a55801 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -164,36 +164,7 @@ let register_callback_fns () = Api_server.callback1 false req sock xml in Xapi_cli.rpc_fun := Some fake_rpc ; - let set_stunnelpid _task_opt pid = - Locking_helpers.Thread_state.acquired - (Locking_helpers.Process ("stunnel", pid)) - in - let unset_stunnelpid _task_opt pid = - Locking_helpers.Thread_state.released - (Locking_helpers.Process ("stunnel", pid)) - in - let stunnel_destination_is_ok addr = - Server_helpers.exec_with_new_task "check_stunnel_destination" - (fun __context -> - let hosts = - Db.Host.get_refs_where ~__context - ~expr:(Eq (Field "address", Literal addr)) - in - match hosts with - | [host] -> ( - try - Message_forwarding.check_live ~__context host ; - true - with _ -> false - ) - | _ -> - true - ) - in - Xmlrpc_client.Internal.set_stunnelpid_callback := Some set_stunnelpid ; - Xmlrpc_client.Internal.unset_stunnelpid_callback := Some unset_stunnelpid ; - Xmlrpc_client.Internal.destination_is_ok := Some stunnel_destination_is_ok ; - TaskHelper.init () + Message_forwarding.register_callback_fns () let noevents = ref false diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 21794537268..93a65dadd12 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -540,6 +540,8 @@ module Watcher = struct is an update *) let cluster_change_interval = Mtime.Span.min + let cluster_stack_watcher : bool Atomic.t = Atomic.make false + (* 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 @@ -573,22 +575,76 @@ module Watcher = struct done ; Atomic.set cluster_change_watcher false + let watch_cluster_stack_version ~__context ~host = + if !Daemon.enabled then + match find_cluster_host ~__context ~host with + | Some ch -> + let cluster_ref = Db.Cluster_host.get_cluster ~__context ~self:ch in + let cluster_rec = + Db.Cluster.get_record ~__context ~self:cluster_ref + in + if + Cluster_stack.of_version + ( cluster_rec.API.cluster_cluster_stack + , cluster_rec.API.cluster_cluster_stack_version + ) + = Cluster_stack.Corosync2 + then ( + debug "%s: Detected Corosync 2 running as cluster stack" + __FUNCTION__ ; + let body = + "The current cluster stack version of Corosync 2 is out of date, \ + consider updating to Corosync 3" + in + let name, priority = Api_messages.cluster_stack_out_of_date in + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + + Helpers.call_api_functions ~__context (fun rpc session_id -> + let _ : [> `message] Ref.t = + Client.Client.Message.create ~rpc ~session_id ~name ~priority + ~cls:`Host ~obj_uuid:host_uuid ~body + in + () + ) + ) + | None -> + debug "%s: No cluster host, no need to watch" __FUNCTION__ + (** [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 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) () + let _ : Thread.t = + Thread.create (fun () -> watch_cluster_change ~__context ~host) () + in + () ) 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__ ; + + if Xapi_cluster_helpers.corosync3_enabled ~__context then + if Atomic.compare_and_set cluster_stack_watcher false true then ( + debug + "%s: create cluster stack watcher for out-of-date cluster stack \ + (corosync2)" + __FUNCTION__ ; + let _ : Thread.t = + Thread.create + (fun () -> watch_cluster_stack_version ~__context ~host) + () + in + () + ) else + debug "%s: not create watcher for cluster stack as it already exists" __FUNCTION__ + ) end diff --git a/ocaml/xapi/xapi_dr_task.ml b/ocaml/xapi/xapi_dr_task.ml index 631c7ee4916..6766775a5f1 100644 --- a/ocaml/xapi/xapi_dr_task.ml +++ b/ocaml/xapi/xapi_dr_task.ml @@ -26,12 +26,7 @@ let make_task ~__context = ref (* A type to represent an SR record parsed from an sr_probe result. *) -type sr_probe_sr = { - uuid: string - ; name_label: string - ; name_description: string - ; metadata_detected: bool -} +type sr_probe_sr = {uuid: string; name_label: string; name_description: string} (* Attempt to parse a key/value pair from XML. *) let parse_kv = function @@ -53,8 +48,6 @@ let parse_sr_probe xml = uuid= List.assoc "UUID" all ; name_label= List.assoc "name_label" all ; name_description= List.assoc "name_description" all - ; metadata_detected= - List.assoc "pool_metadata_detected" all = "true" } | _ -> failwith "Malformed or missing " diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index b56e4199779..8c7432106ab 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -117,17 +117,12 @@ module Next = struct let highest_forgotten_id = ref (-1L) type subscription = { - mutable last_id: int64 - ; (* last event ID to sent to this client *) - mutable subs: Subscription.t list - ; (* list of all the subscriptions *) - m: Mutex.t - ; (* protects access to the mutable fields in this record *) - session: API.ref_session - ; (* session which owns this subscription *) - mutable session_invalid: bool - ; (* set to true if the associated session has been deleted *) - mutable timeout: float (* Timeout *) + mutable last_id: int64 (** last event ID to sent to this client *) + ; mutable subs: Subscription.t list (** all the subscriptions *) + ; m: Mutex.t (** protects access to the mutable fields in this record *) + ; session: API.ref_session (** session which owns this subscription *) + ; mutable session_invalid: bool + (** set to true if the associated session has been deleted *) } (* For Event.next, the single subscription associated with a session *) @@ -235,7 +230,6 @@ module Next = struct ; m= Mutex.create () ; session ; session_invalid= false - ; timeout= 0.0 } in Hashtbl.replace subscriptions session subscription ; diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 0c2417bb829..f52dd8a2709 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -707,7 +707,7 @@ let snapshot_with_quiesce_timeout = ref 600. let host_heartbeat_interval = ref 30. (* If we haven't heard a heartbeat from a host for this interval then the host is assumed dead *) -let host_assumed_dead_interval = ref 600.0 +let host_assumed_dead_interval = ref Mtime.Span.(10 * min) (* If a session has a last_active older than this we delete it *) let inactive_session_timeout = ref 86400. (* 24 hrs in seconds *) @@ -1074,7 +1074,9 @@ let xapi_globs_spec = ; ("wait_memory_target_timeout", Float wait_memory_target_timeout) ; ("snapshot_with_quiesce_timeout", Float snapshot_with_quiesce_timeout) ; ("host_heartbeat_interval", Float host_heartbeat_interval) - ; ("host_assumed_dead_interval", Float host_assumed_dead_interval) + ; ( "host_assumed_dead_interval" + , LongDurationFromSeconds host_assumed_dead_interval + ) ; ("fuse_time", Float Constants.fuse_time) ; ("db_restore_fuse_time", Float Constants.db_restore_fuse_time) ; ("inactive_session_timeout", Float inactive_session_timeout) @@ -1160,15 +1162,8 @@ let options_of_xapi_globs_spec = string_of_float !x | Int x -> string_of_int !x - | ShortDurationFromSeconds x -> - let literal = - Mtime.Span.to_uint64_ns !x |> fun ns -> - Int64.div ns 1_000_000_000L |> Int64.to_int |> string_of_int - in - Fmt.str "%s (%a)" literal Mtime.Span.pp !x - | LongDurationFromSeconds x -> - let literal = Clock.Timer.span_to_s !x |> string_of_float in - Fmt.str "%s (%a)" literal Mtime.Span.pp !x + | ShortDurationFromSeconds x | LongDurationFromSeconds x -> + Fmt.str "%Luns (%a)" (Mtime.Span.to_uint64_ns !x) Mtime.Span.pp !x ) , Printf.sprintf "Set the value of '%s'" name ) diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index 9937fea6f28..578788f8c9c 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -837,7 +837,7 @@ module Monitor = struct (ExnHelper.string_of_exn e) ; Thread.delay !Xapi_globs.ha_monitor_interval done ; - debug "Re-enabling old Host_metrics.live heartbeat" ; + debug "Re-enabling host heartbeat" ; with_lock Db_gc.use_host_heartbeat_for_liveness_m (fun () -> Db_gc.use_host_heartbeat_for_liveness := true ) ; diff --git a/ocaml/xapi/xapi_http.ml b/ocaml/xapi/xapi_http.ml index 13738ff292a..694520a5609 100644 --- a/ocaml/xapi/xapi_http.ml +++ b/ocaml/xapi/xapi_http.ml @@ -90,7 +90,7 @@ let create_session_for_client_cert req s = (* Has been authenticated. Performing RBAC check only ... *) Xapi_session.login_with_password ~__context ~uname:"" ~pwd:"" ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent | Some `root | None -> raise (Http.Unauthorised "") @@ -300,7 +300,7 @@ let server = let server = Http_svr.Server.empty () in server -let http_request = Http.Request.make ~user_agent:Constants.xapi_user_agent +let http_request = Http.Request.make ~user_agent:Xapi_version.xapi_user_agent let bind inetaddr = let description = diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index c14d2acf806..f0cd7c49bfc 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1427,7 +1427,7 @@ let join_common ~__context ~master_address ~master_username ~master_password Client.Session.login_with_password ~rpc:unverified_rpc ~uname:master_username ~pwd:master_password ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent with Http_client.Http_request_rejected _ | Http_client.Http_error _ -> raise (Api_errors.Server_error @@ -1466,7 +1466,7 @@ let join_common ~__context ~master_address ~master_username ~master_password try Client.Session.login_with_password ~rpc ~uname:master_username ~pwd:master_password ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent with Http_client.Http_request_rejected _ | Http_client.Http_error _ -> raise (Api_errors.Server_error diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 1417b4d8313..2a5a933fe6a 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -268,29 +268,14 @@ let set_local_auth_max_threads n = let set_ext_auth_max_threads n = Locking_helpers.Semaphore.set_max throttle_auth_external @@ Int64.to_int n -let wipe_string_contents str = - for i = 0 to Bytes.length str - 1 do - Bytes.set str i '\000' - done - -let wipe ss = List.iter (fun s -> wipe_string_contents s) ss - -(* wrapper that erases sensitive string parameters from functions *) -let wipe_params_after_fn params fn = - try - let r = fn () in - wipe params ; r - with e -> wipe params ; raise e - let do_external_auth uname pwd = with_throttle throttle_auth_external (fun () -> - (Ext_auth.d ()).authenticate_username_password uname - (Bytes.unsafe_to_string pwd) + (Ext_auth.d ()).authenticate_username_password uname pwd ) let do_local_auth uname pwd = with_throttle throttle_auth_internal (fun () -> - try Pam.authenticate uname (Bytes.unsafe_to_string pwd) + try Pam.authenticate uname pwd with Failure msg -> raise Api_errors.(Server_error (session_authentication_failed, [uname; msg])) @@ -298,7 +283,7 @@ let do_local_auth uname pwd = let do_local_change_password uname newpwd = with_throttle throttle_auth_internal (fun () -> - Pam.change_password uname (Bytes.unsafe_to_string newpwd) + Pam.change_password uname newpwd ) let trackid session_id = Context.trackid_of_session (Some session_id) @@ -725,22 +710,19 @@ let slave_local_login ~__context ~psecret = (* Emergency mode login, uses local storage *) let slave_local_login_with_password ~__context ~uname ~pwd = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - let pwd = Bytes.of_string pwd in - wipe_params_after_fn [pwd] (fun () -> - if Context.preauth ~__context <> Some `root then ( - try - (* CP696 - only tries to authenticate against LOCAL superuser account *) - do_local_auth uname pwd - with Failure msg -> - debug "Failed to authenticate user %s: %s" uname msg ; - raise - (Api_errors.Server_error - (Api_errors.session_authentication_failed, [uname; msg]) - ) - ) ; - debug "Add session to local storage" ; - Xapi_local_session.create ~__context ~pool:false - ) + if Context.preauth ~__context <> Some `root then ( + try + (* CP696 - only tries to authenticate against LOCAL superuser account *) + do_local_auth uname pwd + with Failure msg -> + debug "Failed to authenticate user %s: %s" uname msg ; + raise + (Api_errors.Server_error + (Api_errors.session_authentication_failed, [uname; msg]) + ) + ) ; + debug "Add session to local storage" ; + Xapi_local_session.create ~__context ~pool:false (* CP-714: Modify session.login_with_password to first try local super-user login; and then call into external auth plugin if this is enabled @@ -757,415 +739,396 @@ let slave_local_login_with_password ~__context ~uname ~pwd = *) let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = Context.with_tracing ~originator ~__context __FUNCTION__ @@ fun __context -> - let pwd = Bytes.of_string pwd in - wipe_params_after_fn [pwd] (fun () -> - (* !!! Do something with the version number *) - match Context.preauth ~__context with - | Some `root -> - (* in this case, the context origin of this login request is a unix socket bound locally to a filename *) - (* we trust requests from local unix filename sockets, so no need to authenticate them before login *) + (* !!! Do something with the version number *) + match Context.preauth ~__context with + | Some `root -> + (* in this case, the context origin of this login request is a unix socket bound locally to a filename *) + (* we trust requests from local unix filename sockets, so no need to authenticate them before login *) + login_no_password_common ~__context ~uname:(Some uname) ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:"" + ~auth_user_name:uname ~rbac_permissions:[] ~db_ref:None + ~client_certificate:false + | Some `client_cert -> + (* The session was authenticated by stunnel's verification of the client certificate, + so we do not need to verify the username/password. Grant access to functions + based on the special "client_cert" RBAC role. *) + let role = + match + Xapi_role.get_by_name_label ~__context + ~label:Datamodel_roles.role_client_cert + with + | role :: _ -> + role + | [] -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [Datamodel_roles.role_client_cert ^ " role not found"] + ) + ) + in + let rbac_permissions = + Xapi_role.get_permissions_name_label ~__context ~self:role + in + login_no_password_common ~__context ~uname:(Some uname) ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:false ~subject:Ref.null + ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions ~db_ref:None + ~client_certificate:true + | None -> ( + let () = + if Pool_role.is_slave () then + raise + (Api_errors.Server_error + (Api_errors.host_is_slave, [Pool_role.get_master_address ()]) + ) + in + let login_as_local_superuser auth_type = + if auth_type <> "" && uname <> local_superuser then + (* makes local superuser = root only*) + failwith ("Local superuser must be " ^ local_superuser) + else ( + do_local_auth uname pwd ; + debug "Success: local auth, user %s from %s" uname + (Context.get_origin __context) ; login_no_password_common ~__context ~uname:(Some uname) ~originator ~host:(Helpers.get_localhost ~__context) ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions:[] ~db_ref:None ~client_certificate:false - | Some `client_cert -> - (* The session was authenticated by stunnel's verification of the client certificate, - so we do not need to verify the username/password. Grant access to functions - based on the special "client_cert" RBAC role. *) - let role = - match - Xapi_role.get_by_name_label ~__context - ~label:Datamodel_roles.role_client_cert - with - | role :: _ -> - role - | [] -> - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [Datamodel_roles.role_client_cert ^ " role not found"] - ) - ) - in - let rbac_permissions = - Xapi_role.get_permissions_name_label ~__context ~self:role - in - login_no_password_common ~__context ~uname:(Some uname) ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:false ~subject:Ref.null - ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions - ~db_ref:None ~client_certificate:true - | None -> ( - let () = - if Pool_role.is_slave () then - raise - (Api_errors.Server_error - (Api_errors.host_is_slave, [Pool_role.get_master_address ()]) - ) - in - let login_as_local_superuser auth_type = - if auth_type <> "" && uname <> local_superuser then - (* makes local superuser = root only*) - failwith ("Local superuser must be " ^ local_superuser) - else ( - do_local_auth uname pwd ; - debug "Success: local auth, user %s from %s" uname - (Context.get_origin __context) ; - login_no_password_common ~__context ~uname:(Some uname) - ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:true ~subject:Ref.null - ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions:[] - ~db_ref:None ~client_certificate:false + ) + in + let thread_delay_and_raise_error ~error uname msg = + let some_seconds = 5.0 in + Thread.delay some_seconds ; + (* sleep a bit to avoid someone brute-forcing the password *) + if error = Api_errors.session_authentication_failed then + raise (Api_errors.Server_error (error, [uname; msg])) + else if error = Api_errors.session_authorization_failed then + raise Api_errors.(Server_error (error, [uname; msg])) + else + raise + (Api_errors.Server_error + (error, ["session.login_with_password"; msg]) ) - in - let thread_delay_and_raise_error ~error uname msg = - let some_seconds = 5.0 in - Thread.delay some_seconds ; - (* sleep a bit to avoid someone brute-forcing the password *) - if error = Api_errors.session_authentication_failed then - raise (Api_errors.Server_error (error, [uname; msg])) - else if error = Api_errors.session_authorization_failed then - raise Api_errors.(Server_error (error, [uname; msg])) - else - raise - (Api_errors.Server_error - (error, ["session.login_with_password"; msg]) - ) - in - match - Db.Host.get_external_auth_type ~__context - ~self:(Helpers.get_localhost ~__context) - with - | "" as auth_type -> ( - try - (* no external authentication *) + in + match + Db.Host.get_external_auth_type ~__context + ~self:(Helpers.get_localhost ~__context) + with + | "" as auth_type -> ( + try + (* no external authentication *) - (*debug "External authentication is disabled";*) - (* only attempts to authenticate against the local superuser credentials *) - login_as_local_superuser auth_type - with Failure msg -> - info "Failed to locally authenticate user %s from %s: %s" uname + (*debug "External authentication is disabled";*) + (* only attempts to authenticate against the local superuser credentials *) + login_as_local_superuser auth_type + with Failure msg -> + info "Failed to locally authenticate user %s from %s: %s" uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + ) + | _ as auth_type -> ( + (* external authentication required *) + debug "External authentication %s is enabled" auth_type ; + (* 1. first attempts to authenticate against the local superuser *) + try login_as_local_superuser auth_type + with Failure msg -> ( + try + debug "Failed to locally authenticate user %s from %s: %s" uname (Context.get_origin __context) msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname msg - ) - | _ as auth_type -> ( - (* external authentication required *) - debug "External authentication %s is enabled" auth_type ; - (* 1. first attempts to authenticate against the local superuser *) - try login_as_local_superuser auth_type - with Failure msg -> ( + (* 2. then against the external auth service *) + (* 2.1. we first check the external auth service status *) + let rec waiting_event_hook_auth_on_xapi_initialize_succeeded + seconds = + if not !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded + then ( + if seconds <= 0 then ( + let msg = + Printf.sprintf + "External authentication %s service still initializing" + auth_type + in + error "%s" msg ; + thread_delay_and_raise_error uname msg + ~error:Api_errors.internal_error + ) else + debug "External authentication %s service initializing..." + auth_type ; + Thread.delay 1.0 ; + waiting_event_hook_auth_on_xapi_initialize_succeeded + (seconds - 1) + ) + in + waiting_event_hook_auth_on_xapi_initialize_succeeded 120 ; + (* 2.2. we then authenticate the usee using the external authentication plugin *) + (* so that we know that he/she exists there *) + let subject_identifier = try - debug "Failed to locally authenticate user %s from %s: %s" + let _subject_identifier = do_external_auth uname pwd in + debug + "Successful external authentication user %s \ + (subject_identifier, %s from %s)" + uname _subject_identifier + (Context.get_origin __context) ; + _subject_identifier + with Auth_signature.Auth_failure msg -> + info "Failed to externally authenticate user %s from %s: %s" uname (Context.get_origin __context) msg ; - (* 2. then against the external auth service *) - (* 2.1. we first check the external auth service status *) - let rec waiting_event_hook_auth_on_xapi_initialize_succeeded - seconds = - if - not - !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded - then ( - if seconds <= 0 then ( - let msg = - Printf.sprintf - "External authentication %s service still \ - initializing" - auth_type - in - error "%s" msg ; - thread_delay_and_raise_error uname msg - ~error:Api_errors.internal_error - ) else - debug - "External authentication %s service initializing..." - auth_type ; - Thread.delay 1.0 ; - waiting_event_hook_auth_on_xapi_initialize_succeeded - (seconds - 1) - ) - in - waiting_event_hook_auth_on_xapi_initialize_succeeded 120 ; - (* 2.2. we then authenticate the usee using the external authentication plugin *) - (* so that we know that he/she exists there *) - let subject_identifier = - try - let _subject_identifier = do_external_auth uname pwd in - debug - "Successful external authentication user %s \ - (subject_identifier, %s from %s)" - uname _subject_identifier - (Context.get_origin __context) ; - _subject_identifier - with Auth_signature.Auth_failure msg -> - info - "Failed to externally authenticate user %s from %s: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname - msg + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + in + (* as per tests in CP-827, there should be no need to call is_subject_suspended function here, *) + (* because the authentication server in 2.1 will already reflect if account/password expired, *) + (* disabled, locked-out etc, but since likewise doesn't timely reflect this information *) + (* at the same time for both authentication and subject info queries (modification in the AD *) + (* reflects immediately for AD authentication, but can take 1 hour to reflect on subject info), *) + (* we need to call it here in order to be consistent with the session revalidation function. *) + (* Otherwise, there might be cases where the initial authentication/login succeeds, but *) + (* then a few minutes later the revalidation finds that the user is 'suspended' (due to *) + (* subject info caching problems in likewise) and closes the user's session *) + let subject_suspended, subject_name = + try + let suspended, name = + is_subject_suspended ~__context ~cache:true + subject_identifier in - (* as per tests in CP-827, there should be no need to call is_subject_suspended function here, *) - (* because the authentication server in 2.1 will already reflect if account/password expired, *) - (* disabled, locked-out etc, but since likewise doesn't timely reflect this information *) - (* at the same time for both authentication and subject info queries (modification in the AD *) - (* reflects immediately for AD authentication, but can take 1 hour to reflect on subject info), *) - (* we need to call it here in order to be consistent with the session revalidation function. *) - (* Otherwise, there might be cases where the initial authentication/login succeeds, but *) - (* then a few minutes later the revalidation finds that the user is 'suspended' (due to *) - (* subject info caching problems in likewise) and closes the user's session *) - let subject_suspended, subject_name = - try - let suspended, name = - is_subject_suspended ~__context ~cache:true + if suspended then + is_subject_suspended ~__context ~cache:false + subject_identifier + else + (suspended, name) + with Auth_signature.Auth_service_error (_, msg) -> + debug + "Failed to find if user %s (subject_id %s, from %s) is \ + suspended: %s" + uname subject_identifier + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + in + if subject_suspended then ( + let msg = + Printf.sprintf + "User %s (subject_id %s, from %s) suspended in external \ + directory" + uname subject_identifier + (Context.get_origin __context) + in + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + ) else + (* 2.2. then, we verify if any elements of the the membership closure of the externally *) + (* authenticated subject_id is inside our local allowed-to-login subjects list *) + (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) + let group_membership_closure = + try + (Ext_auth.d ()).query_group_membership subject_identifier + with + | Not_found | Auth_signature.Subject_cannot_be_resolved -> + let msg = + Printf.sprintf + "Failed to obtain the group membership closure for \ + user %s (subject_id %s, from %s): user not found in \ + external directory" + uname + (Context.get_origin __context) subject_identifier in - if suspended then - is_subject_suspended ~__context ~cache:false - subject_identifier - else - (suspended, name) - with Auth_signature.Auth_service_error (_, msg) -> + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Auth_signature.Auth_service_error (_, msg) -> debug - "Failed to find if user %s (subject_id %s, from %s) is \ - suspended: %s" + "Failed to obtain the group membership closure for \ + user %s (subject_id %s, from %s): %s" uname subject_identifier (Context.get_origin __context) msg ; thread_delay_and_raise_error ~error:Api_errors.session_authorization_failed uname msg + in + (* finds the intersection between group_membership_closure and pool's table of subject_ids *) + let subjects_in_db = Db.Subject.get_all ~__context in + let subject_ids_in_db = + List.map + (fun subj -> + ( subj + , Db.Subject.get_subject_identifier ~__context ~self:subj + ) + ) + subjects_in_db + in + let reflexive_membership_closure = + subject_identifier :: group_membership_closure + in + (* returns all elements of reflexive_membership_closure that are inside subject_ids_in_db *) + let intersect ext_sids db_sids = + List.filter + (fun (_, db_sid) -> List.mem db_sid ext_sids) + db_sids + in + let intersection = + intersect reflexive_membership_closure subject_ids_in_db + in + (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) + let in_intersection = intersection <> [] in + if not in_intersection then ( + (* empty intersection: externally-authenticated subject has no login rights in the pool *) + let msg = + Printf.sprintf + "Subject %s (identifier %s, from %s) has no access \ + rights in this pool" + uname subject_identifier + (Context.get_origin __context) + in + info "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + ) else (* compute RBAC structures for the session *) + let subject_membership = List.map fst intersection in + debug "subject membership intersection with subject-list=[%s]" + (List.fold_left + (fun i (subj_ref, sid) -> + let subj_ref = + try + (* attempt to resolve subject_ref -> subject_name *) + List.assoc + Auth_signature + .subject_information_field_subject_name + (Db.Subject.get_other_config ~__context + ~self:subj_ref + ) + with _ -> Ref.string_of subj_ref + in + if i = "" then + subj_ref ^ " (" ^ sid ^ ")" + else + i ^ "," ^ subj_ref ^ " (" ^ sid ^ ")" + ) + "" intersection + ) ; + let rbac_permissions = + get_permissions ~__context ~subject_membership in - if subject_suspended then ( + (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) + if rbac_permissions = [] then ( let msg = Printf.sprintf - "User %s (subject_id %s, from %s) suspended in \ - external directory" + "Subject %s (identifier %s) has no roles in this pool" uname subject_identifier - (Context.get_origin __context) in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg + info "%s" msg ; + thread_delay_and_raise_error uname msg + ~error:Api_errors.rbac_permission_denied ) else - (* 2.2. then, we verify if any elements of the the membership closure of the externally *) - (* authenticated subject_id is inside our local allowed-to-login subjects list *) - (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) - let group_membership_closure = + (* non-empty intersection: externally-authenticated subject has login rights in the pool *) + let subject = + (* return reference for the subject obj in the db *) + (* obs: this obj ref can point to either a user or a group contained in the local subject db list *) try - (Ext_auth.d ()).query_group_membership - subject_identifier - with - | Not_found | Auth_signature.Subject_cannot_be_resolved -> - let msg = - Printf.sprintf - "Failed to obtain the group membership closure \ - for user %s (subject_id %s, from %s): user not \ - found in external directory" - uname - (Context.get_origin __context) - subject_identifier - in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname - msg - | Auth_signature.Auth_service_error (_, msg) -> - debug - "Failed to obtain the group membership closure for \ - user %s (subject_id %s, from %s): %s" - uname subject_identifier - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname - msg - in - (* finds the intersection between group_membership_closure and pool's table of subject_ids *) - let subjects_in_db = Db.Subject.get_all ~__context in - let subject_ids_in_db = - List.map - (fun subj -> - ( subj - , Db.Subject.get_subject_identifier ~__context - ~self:subj + List.find + (fun subj -> + (* is this the subject ref that returned the non-empty intersection?*) + List.hd intersection + = ( subj + , Db.Subject.get_subject_identifier ~__context + ~self:subj + ) ) - ) - subjects_in_db - in - let reflexive_membership_closure = - subject_identifier :: group_membership_closure - in - (* returns all elements of reflexive_membership_closure that are inside subject_ids_in_db *) - let intersect ext_sids db_sids = - List.filter - (fun (_, db_sid) -> List.mem db_sid ext_sids) - db_sids - in - let intersection = - intersect reflexive_membership_closure subject_ids_in_db - in - (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) - let in_intersection = intersection <> [] in - if not in_intersection then ( - (* empty intersection: externally-authenticated subject has no login rights in the pool *) - let msg = - Printf.sprintf - "Subject %s (identifier %s, from %s) has no access \ - rights in this pool" - uname subject_identifier - (Context.get_origin __context) - in - info "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - ) else (* compute RBAC structures for the session *) - let subject_membership = List.map fst intersection in - debug - "subject membership intersection with subject-list=[%s]" - (List.fold_left - (fun i (subj_ref, sid) -> - let subj_ref = - try - (* attempt to resolve subject_ref -> subject_name *) - List.assoc - Auth_signature - .subject_information_field_subject_name - (Db.Subject.get_other_config ~__context - ~self:subj_ref - ) - with _ -> Ref.string_of subj_ref - in - if i = "" then - subj_ref ^ " (" ^ sid ^ ")" - else - i ^ "," ^ subj_ref ^ " (" ^ sid ^ ")" - ) - "" intersection - ) ; - let rbac_permissions = - get_permissions ~__context ~subject_membership - in - (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) - if rbac_permissions = [] then ( + subjects_in_db + (* goes through exactly the same subject list that we went when computing the intersection, *) + (* so that no one is able to undetectably remove/add another subject with the same subject_identifier *) + (* between that time 2.2 and now 2.3 *) + with Not_found -> + (* this should never happen, it shows an inconsistency in the db between 2.2 and 2.3 *) let msg = Printf.sprintf - "Subject %s (identifier %s) has no roles in this \ - pool" + "Subject %s (identifier %s, from %s) is not \ + present in this pool" uname subject_identifier + (Context.get_origin __context) in - info "%s" msg ; - thread_delay_and_raise_error uname msg - ~error:Api_errors.rbac_permission_denied - ) else - (* non-empty intersection: externally-authenticated subject has login rights in the pool *) - let subject = - (* return reference for the subject obj in the db *) - (* obs: this obj ref can point to either a user or a group contained in the local subject db list *) - try - List.find - (fun subj -> - (* is this the subject ref that returned the non-empty intersection?*) - List.hd intersection - = ( subj - , Db.Subject.get_subject_identifier ~__context - ~self:subj - ) - ) - subjects_in_db - (* goes through exactly the same subject list that we went when computing the intersection, *) - (* so that no one is able to undetectably remove/add another subject with the same subject_identifier *) - (* between that time 2.2 and now 2.3 *) - with Not_found -> - (* this should never happen, it shows an inconsistency in the db between 2.2 and 2.3 *) - let msg = - Printf.sprintf - "Subject %s (identifier %s, from %s) is not \ - present in this pool" - uname subject_identifier - (Context.get_origin __context) - in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed - uname msg - in - login_no_password_common ~__context ~uname:(Some uname) - ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:false ~subject - ~auth_user_sid:subject_identifier - ~auth_user_name:subject_name ~rbac_permissions - ~db_ref:None ~client_certificate:false - (* we only reach this point if for some reason a function above forgot to catch a possible exception in the Auth_signature module*) - with - | Not_found | Auth_signature.Subject_cannot_be_resolved -> - let msg = - Printf.sprintf - "user %s from %s not found in external directory" uname - (Context.get_origin __context) + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname + msg in - debug - "A function failed to catch this exception for user %s \ - during external authentication: %s" - uname msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - | Auth_signature.Auth_failure msg -> - debug - "A function failed to catch this exception for user %s. \ - Auth_failure: %s" - uname msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname msg - | Auth_signature.Auth_service_error (_, msg) -> - debug - "A function failed to catch this exception for user %s \ - from %s during external authentication: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - | Api_errors.Server_error _ as e -> - (* bubble up any api_error already generated *) - raise e - | e -> - (* generic catch-all for unexpected exceptions during external authentication *) - let msg = ExnHelper.string_of_exn e in - debug - "(generic) A function failed to catch this exception for \ - user %s from %s during external authentication: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.internal_error uname msg - ) - ) + login_no_password_common ~__context ~uname:(Some uname) + ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:false ~subject + ~auth_user_sid:subject_identifier + ~auth_user_name:subject_name ~rbac_permissions + ~db_ref:None ~client_certificate:false + (* we only reach this point if for some reason a function above forgot to catch a possible exception in the Auth_signature module*) + with + | Not_found | Auth_signature.Subject_cannot_be_resolved -> + let msg = + Printf.sprintf + "user %s from %s not found in external directory" uname + (Context.get_origin __context) + in + debug + "A function failed to catch this exception for user %s \ + during external authentication: %s" + uname msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Auth_signature.Auth_failure msg -> + debug + "A function failed to catch this exception for user %s. \ + Auth_failure: %s" + uname msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + | Auth_signature.Auth_service_error (_, msg) -> + debug + "A function failed to catch this exception for user %s from \ + %s during external authentication: %s" + uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Api_errors.Server_error _ as e -> + (* bubble up any api_error already generated *) + raise e + | e -> + (* generic catch-all for unexpected exceptions during external authentication *) + let msg = ExnHelper.string_of_exn e in + debug + "(generic) A function failed to catch this exception for \ + user %s from %s during external authentication: %s" + uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error ~error:Api_errors.internal_error + uname msg + ) ) - ) + ) let change_password ~__context ~old_pwd ~new_pwd = + ignore old_pwd ; Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - let old_pwd = Bytes.of_string old_pwd in - let new_pwd = Bytes.of_string new_pwd in - wipe_params_after_fn [old_pwd; new_pwd] (fun () -> - let session_id = Context.get_session_id __context in - (*let user = Db.Session.get_this_user ~__context ~self:session_id in - let uname = Db.User.get_short_name ~__context ~self:user in*) - let uname = local_superuser in - (* user class has been deprecated *) - if Db.Session.get_is_local_superuser ~__context ~self:session_id then ( - try - (* CP-696: only change password if session has is_local_superuser bit set *) - (* + let session_id = Context.get_session_id __context in + (*let user = Db.Session.get_this_user ~__context ~self:session_id in + let uname = Db.User.get_short_name ~__context ~self:user in*) + let uname = local_superuser in + (* user class has been deprecated *) + if Db.Session.get_is_local_superuser ~__context ~self:session_id then ( + try + (* CP-696: only change password if session has is_local_superuser bit set *) + (* CA-13567: If you have root privileges then we do not authenticate old_pwd; right now, since we only ever have root privileges we just comment this out. @@ -1177,47 +1140,39 @@ let change_password ~__context ~old_pwd ~new_pwd = raise (Api_errors.Server_error (Api_errors.session_authentication_failed,[uname;msg])) end; *) - do_local_change_password uname new_pwd ; - info "Password changed successfully for user %s" uname ; - info "Syncing password change across hosts in pool" ; - (* tell all hosts (except me to sync new passwd file) *) - let hash = Helpers.compute_hash () in - let hosts = Db.Host.get_all ~__context in - let hosts = - List.filter - (fun hostref -> hostref <> !Xapi_globs.localhost_ref) - hosts - in - Helpers.call_api_functions ~__context (fun rpc session_id -> - List.iter - (fun host -> - try - Client.Host.request_config_file_sync ~rpc ~session_id ~host - ~hash - with e -> - error "Failed to sync password to host %s: %s" - (Db.Host.get_name_label ~__context ~self:host) - (Printexc.to_string e) - ) - hosts - ) ; - info "Finished syncing password across pool" - with Failure msg -> - error "Failed to change password for user %s: %s" uname msg ; - raise - (Api_errors.Server_error (Api_errors.change_password_rejected, [msg]) + do_local_change_password uname new_pwd ; + info "Password changed successfully for user %s" uname ; + info "Syncing password change across hosts in pool" ; + (* tell all hosts (except me to sync new passwd file) *) + let hash = Helpers.compute_hash () in + let hosts = Db.Host.get_all ~__context in + let hosts = + List.filter (fun hostref -> hostref <> !Xapi_globs.localhost_ref) hosts + in + Helpers.call_api_functions ~__context (fun rpc session_id -> + List.iter + (fun host -> + try + Client.Host.request_config_file_sync ~rpc ~session_id ~host + ~hash + with e -> + error "Failed to sync password to host %s: %s" + (Db.Host.get_name_label ~__context ~self:host) + (Printexc.to_string e) ) - ) else - (* CP-696: session does not have is_local_superuser bit set, so we must fail *) - let msg = - Printf.sprintf "Failed to change password for user %s" uname - in - debug "User %s is not local superuser: %s" uname msg ; - raise - (Api_errors.Server_error - (Api_errors.user_is_not_local_superuser, [msg]) - ) - ) + hosts + ) ; + info "Finished syncing password across pool" + with Failure msg -> + error "Failed to change password for user %s: %s" uname msg ; + raise + (Api_errors.Server_error (Api_errors.change_password_rejected, [msg])) + ) else + (* CP-696: session does not have is_local_superuser bit set, so we must fail *) + let msg = Printf.sprintf "Failed to change password for user %s" uname in + debug "User %s is not local superuser: %s" uname msg ; + raise + (Api_errors.Server_error (Api_errors.user_is_not_local_superuser, [msg])) let logout ~__context = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 50aa2c6c53d..cb1932aab0a 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -337,19 +337,40 @@ let rtc_timeoffset_of_vm ~__context (vm, vm_t) vbds = ) ) -(* /boot/ contains potentially sensitive files like xen-initrd, so we will only*) -(* allow directly booting guests from the subfolder /boot/guest/ *) -let allowed_dom0_directories_for_boot_files = - ["/boot/guest/"; "/var/lib/xcp/guest"] - -let is_boot_file_whitelisted filename = - let safe_str str = not (String.has_substr str "..") in - (* make sure the script prefix is the allowed dom0 directory *) - List.exists - (fun allowed -> String.starts_with ~prefix:allowed filename) - allowed_dom0_directories_for_boot_files - (* avoid ..-style attacks and other weird things *) - && safe_str filename +let allowed_dom0_directories_for_boot_files = ["/var/lib/xcp/guest/"] + +let kernel_path filename = + let ( let* ) = Result.bind in + let* real_path = + try Ok (Unix.realpath filename) with + | Unix.(Unix_error (ENOENT, _, _)) -> + let reason = "File does not exist" in + Error (filename, reason) + | exn -> + let reason = Printexc.to_string exn in + Error (filename, reason) + in + let* () = + match Unix.stat real_path with + | {st_kind= Unix.S_REG; _} -> + Ok () + | _ -> + let reason = "Is not a regular file" in + Error (filename, reason) + in + let allowed = + List.exists + (fun allowed -> String.starts_with ~prefix:allowed real_path) + allowed_dom0_directories_for_boot_files + in + if not allowed then + let reason = + Printf.sprintf "Is not in any of the allowed kernel directories: [%s]" + (String.concat "; " allowed_dom0_directories_for_boot_files) + in + Error (filename, reason) + else + Ok real_path let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = let open Vm in @@ -372,19 +393,12 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = Cirrus in let pci_emulations = - let s = - try Some (List.assoc "mtc_pci_emulations" vm.API.vM_other_config) - with _ -> None - in + let s = List.assoc_opt "mtc_pci_emulations" vm.API.vM_other_config in match s with | None -> [] - | Some x -> ( - try - let l = String.split ',' x in - List.map (String.strip String.isspace) l - with _ -> [] - ) + | Some x -> + String.split_on_char ',' x |> List.map String.trim in let make_hvmloader_boot_record () = if bool vm.API.vM_platform false "qemu_stubdom" then @@ -427,15 +441,10 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = ; acpi= bool vm.API.vM_platform true "acpi" ; serial= ((* The platform value should override the other_config value. If - * neither are set, use pty. *) + neither are set, use pty. *) let key = "hvm_serial" in - let other_config_value = - try Some (List.assoc key vm.API.vM_other_config) - with Not_found -> None - in - let platform_value = - try Some (List.assoc key vm.API.vM_platform) with Not_found -> None - in + let other_config_value = List.assoc_opt key vm.API.vM_other_config in + let platform_value = List.assoc_opt key vm.API.vM_platform in match (other_config_value, platform_value) with | None, None -> Some "pty" @@ -444,10 +453,7 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = | Some value, None -> Some value ) - ; keymap= - ( try Some (List.assoc "keymap" vm.API.vM_platform) - with Not_found -> None - ) + ; keymap= List.assoc_opt "keymap" vm.API.vM_platform ; vnc_ip= None (*None PR-1255*) ; pci_emulations ; pci_passthrough @@ -464,30 +470,19 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = ; tpm= tpm_of_vm () } in - let make_direct_boot_record - {Helpers.kernel= k; kernel_args= ka; ramdisk= initrd} = - let k = - if is_boot_file_whitelisted k then - k - else ( - debug "kernel %s is not in the whitelist: ignoring" k ; - "" - ) - in - let initrd = - Option.map - (fun x -> - if is_boot_file_whitelisted x then - x - else ( - debug "initrd %s is not in the whitelist: ignoring" k ; - "" - ) - ) - initrd + let make_direct_boot_record {Helpers.kernel; kernel_args= ka; ramdisk} = + let resolve name ~path = + match kernel_path path with + | Ok k -> + k + | Error (file, msg) -> + info {|%s: refusing to load %s "%s": %s|} __FUNCTION__ name file msg ; + raise Api_errors.(Server_error (invalid_value, [name; file; msg])) in + let kernel = resolve "kernel" ~path:kernel in + let ramdisk = Option.map (fun k -> resolve "ramdisk" ~path:k) ramdisk in { - boot= Direct {kernel= k; cmdline= ka; ramdisk= initrd} + boot= Direct {kernel; cmdline= ka; ramdisk} ; framebuffer= bool vm.API.vM_platform false "pvfb" ; framebuffer_ip= None (* None PR-1255 *) ; vncterm= not (List.mem_assoc "disable_pv_vnc" vm.API.vM_other_config) diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 29142383a22..e01e010a77f 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -5,7 +5,7 @@ (modules (:standard \ xcp_rrdd)) (libraries astring - dune-build-info + ezxenstore gzip http_lib @@ -33,7 +33,6 @@ xmlm yojson ) - (preprocess (pps ppx_deriving_rpc)) ) (executable @@ -44,7 +43,7 @@ (modules xcp_rrdd) (libraries astring - dune-build-info + ezxenstore.core ezxenstore.watch forkexec diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index f3f56003dad..9662af66611 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -457,8 +457,8 @@ let query_host_ds (ds_name : string) : float = ) (** Dump all latest data of host dss to file in json format so that any client - can read even if it's non-privileged user, such as NRPE. - Especially, nan, infinity and neg_infinity will be converted to strings + can read even if it's non-privileged user, such as NRPE. + Especially, nan, infinity and neg_infinity will be converted to strings "NaN", "infinity" and "-infinity", the client needs to handle by itself. *) let convert_value x = @@ -651,8 +651,7 @@ module Plugin = struct - Can the code for backwards compatibility be expunged? *) type plugin = { - info: P.info - ; reader: Rrd_reader.reader + reader: Rrd_reader.reader ; mutable skip_init: int (** initial value for skip after read err *) ; mutable skip: int (** number of cycles to skip b/f next read *) } @@ -748,7 +747,7 @@ module Plugin = struct let reader = P.make_reader ~uid ~info ~protocol:(choose_protocol protocol) in - Hashtbl.add registered uid {info; reader; skip_init= 1; skip= 0} + Hashtbl.add registered uid {reader; skip_init= 1; skip= 0} ) ; next_reading uid diff --git a/ocaml/xcp-rrdd/bin/rrddump/dune b/ocaml/xcp-rrdd/bin/rrddump/dune index 9af30f6fabc..0e79375137d 100644 --- a/ocaml/xcp-rrdd/bin/rrddump/dune +++ b/ocaml/xcp-rrdd/bin/rrddump/dune @@ -3,7 +3,7 @@ (name rrddump) (public_name rrddump) (libraries - dune-build-info + rrd-transport xapi-rrd xapi-rrd.unix diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune index 0f438a65861..6e422954c79 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune @@ -4,7 +4,7 @@ (package rrdd-plugins) (public_name xcp-rrdd-dcmi) (libraries - dune-build-info + rrdd-plugin rrdd-plugins.libs xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/bin/rrdp-dummy/dune b/ocaml/xcp-rrdd/bin/rrdp-dummy/dune index 6441afe0f61..c3ff89a1c35 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-dummy/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-dummy/dune @@ -3,7 +3,7 @@ (public_name rrdp_dummy) (package xapi-rrdd-plugin) (libraries - dune-build-info + rrdd-plugin xapi-idl.rrd xapi-rrd diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune index 4c6dd005206..7933a9a3fdc 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune @@ -6,7 +6,7 @@ (libraries astring cstruct - dune-build-info + ezxenstore.core inotify mtime diff --git a/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune b/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune index 69a0f05cf98..955b2bdecb9 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune @@ -4,7 +4,7 @@ (package rrdd-plugins) (public_name xcp-rrdd-squeezed) (libraries - dune-build-info + rrdd-plugin rrdd-plugins.libs xapi-stdext-std diff --git a/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune b/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune index 8e71461e3fb..f28b84ef511 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune @@ -4,7 +4,7 @@ (package rrdd-plugins) (public_name xcp-rrdd-xenpm) (libraries - dune-build-info + rrdd-plugin rrdd-plugins.libs str diff --git a/ocaml/xcp-rrdd/bin/transport-rw/dune b/ocaml/xcp-rrdd/bin/transport-rw/dune index 9630a477ac4..1b933823051 100644 --- a/ocaml/xcp-rrdd/bin/transport-rw/dune +++ b/ocaml/xcp-rrdd/bin/transport-rw/dune @@ -5,7 +5,7 @@ (package xapi-rrd-transport-utils) (libraries cmdliner - dune-build-info + rrd-transport threads.posix xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/test/rrdd/dune b/ocaml/xcp-rrdd/test/rrdd/dune index 699ae424bfe..bf654c0e66f 100644 --- a/ocaml/xcp-rrdd/test/rrdd/dune +++ b/ocaml/xcp-rrdd/test/rrdd/dune @@ -4,12 +4,11 @@ (package xapi-rrdd) (libraries alcotest - dune-build-info + fmt rrdd_libs_internal xapi-idl.rrd xapi-rrd ) - (preprocess (pps ppx_deriving_rpc)) ) diff --git a/ocaml/xcp-rrdd/test/transport/dune b/ocaml/xcp-rrdd/test/transport/dune index 333b4db49ce..4efd2bc042d 100644 --- a/ocaml/xcp-rrdd/test/transport/dune +++ b/ocaml/xcp-rrdd/test/transport/dune @@ -3,7 +3,7 @@ (package rrd-transport) (libraries alcotest - dune-build-info + fmt rrd-transport xapi-idl.rrd diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index f72cacbbda4..5362781b31a 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -5,7 +5,7 @@ (package xe) (libraries astring - dune-build-info + fpath safe-resources stunnel diff --git a/ocaml/xen-api-client/async_examples/dune b/ocaml/xen-api-client/async_examples/dune index 7cfce054d69..7d39e42c902 100644 --- a/ocaml/xen-api-client/async_examples/dune +++ b/ocaml/xen-api-client/async_examples/dune @@ -9,7 +9,7 @@ base.caml core core_kernel - dune-build-info + xapi-consts xapi-types xen-api-client @@ -27,9 +27,7 @@ base base.caml core - core_kernel - dune-build-info - ppx_sexp_conv.runtime-lib + core_kernel rpclib.json sexplib0 xapi-consts diff --git a/ocaml/xen-api-client/lib/dune b/ocaml/xen-api-client/lib/dune index dd26361adef..bf0181ea3a3 100644 --- a/ocaml/xen-api-client/lib/dune +++ b/ocaml/xen-api-client/lib/dune @@ -2,7 +2,6 @@ (name xen_api_client) (public_name xen-api-client) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) (libraries astring cohttp diff --git a/ocaml/xen-api-client/lib_test/dune b/ocaml/xen-api-client/lib_test/dune index 12e1921130c..cc868d261b6 100644 --- a/ocaml/xen-api-client/lib_test/dune +++ b/ocaml/xen-api-client/lib_test/dune @@ -2,7 +2,7 @@ (name xen_api_test) (package xen-api-client) (libraries - dune-build-info + alcotest rpclib.xml uri diff --git a/ocaml/xen-api-client/lib_test/xen_api_test.ml b/ocaml/xen-api-client/lib_test/xen_api_test.ml index b8729de197c..14208242465 100644 --- a/ocaml/xen-api-client/lib_test/xen_api_test.ml +++ b/ocaml/xen-api-client/lib_test/xen_api_test.ml @@ -46,13 +46,13 @@ module Fake_IO = struct let flush _oc = return () - type connection = {address: Uri.t; ic: ic; oc: ic} + type connection = {ic: ic; oc: ic} let connections = ref [] - let open_connection address = + let open_connection _ = let ic = Queue.create () and oc = Queue.create () in - let c = {address; ic; oc} in + let c = {ic; oc} in connections := c :: !connections ; return (Ok (ic, oc)) @@ -111,7 +111,7 @@ let test_login_success () = let module Fake_IO = struct include Fake_IO - let open_connection address = + let open_connection _ = let ic = Queue.create () and oc = Queue.create () in Queue.push "HTTP/1.1 200 OK\r\n" ic ; Queue.push @@ -119,7 +119,7 @@ let test_login_success () = ic ; Queue.push "\r\n" ic ; Queue.push result ic ; - let c = {address; ic; oc} in + let c = {ic; oc} in connections := c :: !connections ; return (Ok (ic, oc)) end in diff --git a/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml b/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml index 935f3e85ccb..ae88acf576c 100644 --- a/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml +++ b/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml @@ -15,117 +15,129 @@ * *) -type 'a t = 'a Lwt.t +module type ChannelType = sig + type t -let iter fn x = Lwt_list.iter_s fn x + type reader = Cstruct.t -> unit Lwt.t -let return = Lwt.return + val really_read : t -> reader -let ( >>= ) = Lwt.bind + val really_write : t -> reader +end -let ( >> ) m n = m >>= fun _ -> n +module Make (Ch : ChannelType) = struct + type 'a t = 'a Lwt.t -(** Use as few really_{read,write} calls as we can (for efficiency) without + let iter fn x = Lwt_list.iter_s fn x + + let return = Lwt.return + + let ( >>= ) = Lwt.bind + + let ( >> ) m n = m >>= fun _ -> n + + (** Use as few really_{read,write} calls as we can (for efficiency) without explicitly buffering the stream beyond the HTTP headers. This will allow us to consume the headers and then pass the file descriptor safely to another process *) -type ic = { - mutable header_buffer: string option (** buffered headers *) - ; mutable header_buffer_idx: int (** next char within the buffered headers *) - ; c: Data_channel.t -} - -let make_input c = - let header_buffer = None in - let header_buffer_idx = 0 in - {header_buffer; header_buffer_idx; c} - -type oc = Data_channel.t - -type conn = Data_channel.t - -let really_read_into c buf ofs len = - let tmp = Cstruct.create len in - c.Data_channel.really_read tmp >>= fun () -> - Cstruct.blit_to_bytes tmp 0 buf ofs len ; - return () - -let read_http_headers c = - let buf = Buffer.create 128 in - (* We can safely read everything up to this marker: *) - let end_of_headers = "\r\n\r\n" in - let tmp = Bytes.make (String.length end_of_headers) '\000' in - let module Scanner = struct - type t = {marker: string; mutable i: int} - - let make x = {marker= x; i= 0} - - let input x c = - if c = String.get x.marker x.i then x.i <- x.i + 1 else x.i <- 0 - - let remaining x = String.length x.marker - x.i - - let matched x = x.i = String.length x.marker - (* let to_string x = Printf.sprintf "%d" x.i *) - end in - let marker = Scanner.make end_of_headers in - - let rec loop () = - if not (Scanner.matched marker) then ( - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) - let safe_to_read = Scanner.remaining marker in - - really_read_into c tmp 0 safe_to_read >>= fun () -> - for j = 0 to safe_to_read - 1 do - Scanner.input marker (Bytes.get tmp j) ; - Buffer.add_char buf (Bytes.get tmp j) - done ; - loop () - ) else - return () - in - loop () >>= fun () -> return (Buffer.contents buf) - -(* We assume read_line is only used to read the HTTP header *) -let rec read_line ic = - match (ic.header_buffer, ic.header_buffer_idx) with - | None, _ -> - read_http_headers ic.c >>= fun str -> - ic.header_buffer <- Some str ; - read_line ic - | Some buf, i when i < String.length buf -> ( - match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with - | Some eol -> - let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2 ; - return (Some line) - | None -> + type ic = { + mutable header_buffer: string option (** buffered headers *) + ; mutable header_buffer_idx: int + (** next char within the buffered headers *) + ; c: Ch.t + } + + let make_input c = + let header_buffer = None in + let header_buffer_idx = 0 in + {header_buffer; header_buffer_idx; c} + + type oc = Ch.t + + type conn = Ch.t + + let really_read_into c buf ofs len = + let tmp = Cstruct.create len in + (Ch.really_read c) tmp >>= fun () -> + Cstruct.blit_to_bytes tmp 0 buf ofs len ; + return () + + let read_http_headers c = + let buf = Buffer.create 128 in + (* We can safely read everything up to this marker: *) + let end_of_headers = "\r\n\r\n" in + let tmp = Bytes.make (String.length end_of_headers) '\000' in + let module Scanner = struct + type t = {marker: string; mutable i: int} + + let make x = {marker= x; i= 0} + + let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 + + let remaining x = String.length x.marker - x.i + + let matched x = x.i = String.length x.marker + end in + let marker = Scanner.make end_of_headers in + + let rec loop () = + if not (Scanner.matched marker) then ( + (* We may be part way through reading the end of header marker, so + be pessimistic and only read enough bytes to read until the end of + the marker. *) + let safe_to_read = Scanner.remaining marker in + + really_read_into c tmp 0 safe_to_read >>= fun () -> + for j = 0 to safe_to_read - 1 do + Scanner.input marker (Bytes.get tmp j) ; + Buffer.add_char buf (Bytes.get tmp j) + done ; + loop () + ) else + return () + in + loop () >>= fun () -> return (Buffer.contents buf) + + (* We assume read_line is only used to read the HTTP header *) + let rec read_line ic = + match (ic.header_buffer, ic.header_buffer_idx) with + | None, _ -> + read_http_headers ic.c >>= fun str -> + ic.header_buffer <- Some str ; + read_line ic + | Some buf, i when i < String.length buf -> ( + match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with + | Some eol -> + let line = String.sub buf i (eol - i) in + ic.header_buffer_idx <- eol + 2 ; + return (Some line) + | None -> + return (Some "") + ) + | Some _, _ -> return (Some "") - ) - | Some _, _ -> - return (Some "") - -let read_into_exactly ic buf ofs len = - really_read_into ic.c buf ofs len >>= fun () -> return true - -let read_exactly ic len = - let buf = Bytes.create len in - read_into_exactly ic buf 0 len >>= function - | true -> - return (Some buf) - | false -> - return None - -let read ic n = - let buf = Bytes.make n '\000' in - really_read_into ic.c buf 0 n >>= fun () -> return (Bytes.unsafe_to_string buf) - -let write oc x = - let buf = Cstruct.create (String.length x) in - Cstruct.blit_from_string x 0 buf 0 (String.length x) ; - oc.Data_channel.really_write buf - -let flush _oc = return () + + let read_into_exactly ic buf ofs len = + really_read_into ic.c buf ofs len >>= fun () -> return true + + let read_exactly ic len = + let buf = Bytes.create len in + read_into_exactly ic buf 0 len >>= function + | true -> + return (Some buf) + | false -> + return None + + let read ic n = + let buf = Bytes.make n '\000' in + really_read_into ic.c buf 0 n >>= fun () -> + return (Bytes.unsafe_to_string buf) + + let write oc x = + let buf = Cstruct.create (String.length x) in + Cstruct.blit_from_string x 0 buf 0 (String.length x) ; + (Ch.really_write oc) buf + + let flush _oc = return () +end diff --git a/ocaml/xen-api-client/lwt/disk.ml b/ocaml/xen-api-client/lwt/disk.ml index fb8f4fc9500..e17a816f94a 100644 --- a/ocaml/xen-api-client/lwt/disk.ml +++ b/ocaml/xen-api-client/lwt/disk.ml @@ -60,6 +60,27 @@ let socket sockaddr = in Lwt_unix.socket family Unix.SOCK_STREAM 0 +module DataChannelConstrained : sig + type t = Data_channel.t + + type reader = Cstruct.t -> unit Lwt.t + + val really_read : t -> reader + + val really_write : t -> reader +end = struct + type t = Data_channel.t + + type reader = Cstruct.t -> unit Lwt.t + + let really_read x = x.Data_channel.really_read + + let really_write x = x.Data_channel.really_write +end + +module Cohttp_io_with_channel = + Cohttp_unbuffered_io.Make (DataChannelConstrained) + let start_upload ~chunked ~uri = Uri_util.sockaddr_of_uri uri >>= fun (sockaddr, use_ssl) -> let sock = socket sockaddr in @@ -74,8 +95,8 @@ let start_upload ~chunked ~uri = Data_channel.of_fd ~seekable:false sock ) >>= fun c -> - let module Request = Request.Make (Cohttp_unbuffered_io) in - let module Response = Response.Make (Cohttp_unbuffered_io) in + let module Request = Request.Make (Cohttp_io_with_channel) in + let module Response = Response.Make (Cohttp_io_with_channel) in let headers = Header.init () in let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in let headers = if chunked then Header.add headers k v else headers in @@ -101,7 +122,7 @@ let start_upload ~chunked ~uri = Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri in Request.write (fun _ -> return ()) request c >>= fun () -> - Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r -> + Response.read (Cohttp_io_with_channel.make_input c) >>= fun r -> match r with | `Eof | `Invalid _ -> fail (Failure "Unable to parse HTTP response from server") diff --git a/ocaml/xen-api-client/lwt_examples/dune b/ocaml/xen-api-client/lwt_examples/dune index ba5fe7c95e2..56d95a3e6d9 100644 --- a/ocaml/xen-api-client/lwt_examples/dune +++ b/ocaml/xen-api-client/lwt_examples/dune @@ -3,7 +3,7 @@ (name list_vms) (modules list_vms) (libraries - dune-build-info + lwt lwt.unix uri @@ -20,7 +20,7 @@ (modules upload_disk) (libraries cstruct - dune-build-info + lwt lwt.unix uri @@ -40,7 +40,7 @@ cohttp-lwt cohttp-lwt-unix conduit-lwt-unix - dune-build-info + lwt lwt.unix ssl diff --git a/ocaml/xenforeign/dune b/ocaml/xenforeign/dune index 8e6b3118042..d120d9669cd 100644 --- a/ocaml/xenforeign/dune +++ b/ocaml/xenforeign/dune @@ -1,4 +1,4 @@ (executable (name main) - (libraries bigarray-compat cstruct dune-build-info xenctrl xenopsd_xc hex) + (libraries bigarray-compat cstruct xenctrl xenopsd_xc hex) ) diff --git a/ocaml/xenopsd/cli/dune b/ocaml/xenopsd/cli/dune index b194b10323c..0b2e0f0c2cf 100644 --- a/ocaml/xenopsd/cli/dune +++ b/ocaml/xenopsd/cli/dune @@ -8,7 +8,7 @@ (libraries astring cmdliner - dune-build-info + re result rpclib.core @@ -23,7 +23,7 @@ xapi-idl.xen.interface.types xapi-stdext-pervasives ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Common Xn_cfg_types))) ) (rule diff --git a/ocaml/xenopsd/dbgring/dune b/ocaml/xenopsd/dbgring/dune index 0f79c13e2f0..3d95198039f 100644 --- a/ocaml/xenopsd/dbgring/dune +++ b/ocaml/xenopsd/dbgring/dune @@ -3,7 +3,7 @@ (public_name dbgring) (package xapi-xenopsd-xc) (libraries - dune-build-info + xapi-xenopsd xenctrl xenmmap diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index 6f5bce8b12f..85377322942 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -47,6 +47,9 @@ xmlm ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module + ((pps ppx_sexp_conv) Suspend_image) + ((pps ppx_deriving_rpc) Interface Xenops_hooks Xenops_migrate Xenops_server Xenops_server_plugin Xenops_server_simulator) + ) ) ) diff --git a/ocaml/xenopsd/list_domains/dune b/ocaml/xenopsd/list_domains/dune index 2856c531e38..be8407cb32d 100644 --- a/ocaml/xenopsd/list_domains/dune +++ b/ocaml/xenopsd/list_domains/dune @@ -2,5 +2,5 @@ (name list_domains) (public_name list_domains) (package xapi-xenopsd-xc) - (libraries dune-build-info xenctrl xapi-idl.memory ezxenstore.watch uuid) + (libraries xenctrl xapi-idl.memory ezxenstore.watch uuid) ) diff --git a/ocaml/xenopsd/simulator/dune b/ocaml/xenopsd/simulator/dune index 8fc0d86f669..740b6d9b9e0 100644 --- a/ocaml/xenopsd/simulator/dune +++ b/ocaml/xenopsd/simulator/dune @@ -3,7 +3,7 @@ (public_name xenopsd-simulator) (package xapi-xenopsd-simulator) (libraries - dune-build-info + xapi-idl.xen.interface xapi-xenopsd ) diff --git a/ocaml/xenopsd/test/dune b/ocaml/xenopsd/test/dune index 6c793a3c1bd..a71ad643db9 100644 --- a/ocaml/xenopsd/test/dune +++ b/ocaml/xenopsd/test/dune @@ -5,7 +5,7 @@ (libraries alcotest cpuid - dune-build-info + fmt result rpclib.core @@ -20,7 +20,7 @@ xenstore_transport.unix ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module ((pps ppx_deriving_rpc) Test)) ) ) diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 7fedcaa3207..4a79452dbbe 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -1,5 +1,6 @@ (library (name xenopsd_xc) + (modes best) (modules :standard \ xenops_xc_main memory_breakdown @@ -56,7 +57,9 @@ ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module + ((pps ppx_deriving_rpc) Device Device_common Domain Xenops_server_xen) + ) ) (wrapped false) ) @@ -68,7 +71,7 @@ (modules xenops_xc_main) (libraries - dune-build-info + ezxenstore.core uuid xapi-idl @@ -89,7 +92,7 @@ (libraries astring cmdliner - dune-build-info + ezxenstore.core uuid xapi-idl.memory @@ -106,7 +109,7 @@ (modes exe) (modules memory_summary) (libraries - dune-build-info + xapi-stdext-date xapi-stdext-unix xapi-xenopsd @@ -131,7 +134,7 @@ (modules cancel_utils_test) (libraries cmdliner - dune-build-info + ezxenstore.core threads.posix xapi-idl.xen.interface diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index 7b4051306c7..0be1866b2d0 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -1,5 +1,5 @@ (executable - (modes byte exe) + (modes exe) (name xs_trace) (public_name xs-trace) (package xapi) diff --git a/ocaml/xs-trace/test/dune b/ocaml/xs-trace/test/dune index 2e140017a28..d794381a742 100644 --- a/ocaml/xs-trace/test/dune +++ b/ocaml/xs-trace/test/dune @@ -1,5 +1,5 @@ (executable - (modes byte exe) + (modes exe) (name test_xs_trace) (libraries unix)) diff --git a/ocaml/xsh/dune b/ocaml/xsh/dune index 13fc1e74c46..121c95186e6 100644 --- a/ocaml/xsh/dune +++ b/ocaml/xsh/dune @@ -4,7 +4,7 @@ (public_name xsh) (package xapi) (libraries - dune-build-info + stunnel safe-resources xapi-consts diff --git a/ocaml/xsh/xsh.ml b/ocaml/xsh/xsh.ml index 982ff6c346f..51de04f257a 100644 --- a/ocaml/xsh/xsh.ml +++ b/ocaml/xsh/xsh.ml @@ -19,7 +19,7 @@ open D type endpoint = { fdin: Unix.file_descr ; fdout: Unix.file_descr - ; mutable buffer: bytes + ; buffer: bytes ; mutable buffer_len: int } diff --git a/ocaml/xxhash/lib/dune b/ocaml/xxhash/lib/dune index 70b43c59192..8b018491119 100644 --- a/ocaml/xxhash/lib/dune +++ b/ocaml/xxhash/lib/dune @@ -11,6 +11,7 @@ (language c) (names xxhash_stubs) ) + (modes best) (name xxhash) (wrapped false) (libraries diff --git a/ocaml/xxhash/stubs/dune b/ocaml/xxhash/stubs/dune index 575fcd1e00a..e9da18174f6 100644 --- a/ocaml/xxhash/stubs/dune +++ b/ocaml/xxhash/stubs/dune @@ -10,6 +10,7 @@ (library (name xxhash_bindings) + (modes best) (libraries ctypes ctypes.stubs diff --git a/quality-gate.sh b/quality-gate.sh index b3cd2e67813..8f761718627 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=515 + N=513 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) @@ -95,7 +95,7 @@ ocamlyacc () { unixgetenv () { - N=1 + N=0 UNIXGETENV=$(git grep -P -r -o --count 'getenv(?!_opt)' -- **/*.ml | wc -l) if [ "$UNIXGETENV" -eq "$N" ]; then echo "OK found $UNIXGETENV usages of exception-raising Unix.getenv in OCaml files." diff --git a/rrd-transport.opam b/rrd-transport.opam index 55ff4e7b0b2..07fe41dd8cc 100644 --- a/rrd-transport.opam +++ b/rrd-transport.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "cstruct" diff --git a/rrdd-plugin.opam b/rrdd-plugin.opam index 6bab281c970..5b113952b04 100644 --- a/rrdd-plugin.opam +++ b/rrdd-plugin.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" "astring" "rpclib" diff --git a/scripts/Makefile b/scripts/Makefile index 18e923c69fa..b47c36f5358 100644 --- a/scripts/Makefile +++ b/scripts/Makefile @@ -121,7 +121,6 @@ install: $(IPROG) print-custom-templates $(DESTDIR)$(LIBEXECDIR) $(IPROG) backup-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) $(IPROG) restore-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) - $(IPROG) probe-device-for-file $(DESTDIR)$(LIBEXECDIR) $(IPROG) backup-metadata-cron $(DESTDIR)$(LIBEXECDIR) $(IPROG) pbis-force-domain-leave $(DESTDIR)$(LIBEXECDIR) mkdir -p $(DESTDIR)/etc/sysconfig diff --git a/scripts/probe-device-for-file b/scripts/probe-device-for-file deleted file mode 100755 index be07f40758f..00000000000 --- a/scripts/probe-device-for-file +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/bin/env python3 -# (c) Anil Madhavapeddy, Citrix Systems Inc, 2008 -# Checks for the existence of a file on a device - -import os, sys -try: - import xenfsimage -except ImportError: - import fsimage as xenfsimage -from contextlib import contextmanager - -# https://stackoverflow.com/a/17954769 -@contextmanager -def stderr_redirected(to=os.devnull): - ''' - import os - - with stderr_redirected(to=filename): - print("from Python") - os.system("echo non-Python applications are also supported") - ''' - fd = sys.stderr.fileno() - - ##### assert that Python and C stdio write using the same file descriptor - ####assert libc.fileno(ctypes.c_void_p.in_dll(libc, "stderr")) == fd == 1 - - def _redirect_stderr(to): - sys.stderr.close() # + implicit flush() - os.dup2(to.fileno(), fd) # fd writes to 'to' file - sys.stderr = os.fdopen(fd, 'w') # Python writes to fd - - with os.fdopen(os.dup(fd), 'w') as old_stderr: - with open(to, 'w') as file: - _redirect_stderr(to=file) - try: - yield # allow code to be run with the redirected stderr - finally: - _redirect_stderr(to=old_stderr) # restore stderr. - # buffering and flags such as - # CLOEXEC may be different - -if __name__ == "__main__": - if len(sys.argv) != 3: - print("Usage: %s " % sys.argv[0]) - sys.exit(2) - device = sys.argv[1] - file = sys.argv[2] - try: - # CA-316241 - fsimage prints to stderr - with stderr_redirected(to="/dev/null"): - fs = xenfsimage.open(device, 0) - if fs.file_exists(file): - os._exit(0) - except: - pass - os._exit(1) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 47b21108b9d..43c4617ec3b 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -39,7 +39,6 @@ function usage { echo " -k: Number of older backups to preserve (default: ${history_kept})" echo " -n: Just try to find a backup VDI and stop the script after that" echo " -f Force backup even when less than 10% free capacity is left on the backup VDI" - echo " -y: Assume non-interactive mode and yes to all questions" echo " -v: Verbose output" echo echo @@ -55,23 +54,6 @@ function uuid5 { python -c "import uuid; print (uuid.uuid5(uuid.UUID('$1'), '$2'))" } -function validate_vdi_uuid { - # we check that vdi has the expected UUID which depends on the UUID of - # the SR. This is a deterministic hash of the SR UUID and the - # namespace UUID $NS. This UUID must match what Xapi's Uuidx module is using. - local NS="e93e0639-2bdb-4a59-8b46-352b3f408c19" - local sr="$1" - local vdi="$2" - local uuid - - uuid=$(uuid5 "$NS" "$sr") - if [ "$vdi" != "$uuid" ]; then - return 1 - else - return 0 - fi -} - function test_sr { sr_uuid_found=$(${XE} sr-list uuid="$1" --minimal) if [ "${sr_uuid_found}" != "$1" ]; then @@ -87,7 +69,6 @@ just_find_vdi=0 fs_uninitialised=0 usage_alert=90 force_backup=0 -yes=0 while getopts "yhvink:u:dcf" opt ; do case $opt in h) usage ;; @@ -98,7 +79,6 @@ while getopts "yhvink:u:dcf" opt ; do d) leave_mounted=1 ;; n) just_find_vdi=1 ;; v) debug="" ;; - y) yes=1 ;; f) force_backup=1 ;; *) echo "Invalid option"; usage ;; esac @@ -120,8 +100,8 @@ fi test_sr "${sr_uuid}" sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label) -# see if a backup VDI already exists on the selected SR -vdi_uuid=$(${XE} vdi-list other-config:ctxs-pool-backup=true sr-uuid="${sr_uuid}" params=uuid --minimal) +# assume use of the new format predictable UUID +vdi_uuid=$(${XE} vdi-list uuid="$(uuid5 "e93e0639-2bdb-4a59-8b46-352b3f408c19" "$sr_uuid")" --minimal) mnt= function cleanup { @@ -135,42 +115,14 @@ function cleanup { if [ ! -z "${vbd_uuid}" ]; then ${debug} echo -n "Unplugging VBD: " ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20 - # poll for the device to go away if we know its name - if [ "${device}" != "" ]; then - device_gone=0 - for ((i=0; i<10; i++)); do - ${debug} echo -n "." - if [ ! -b "${device}" ]; then - ${debug} echo " done" - device_gone=1 - break - fi - sleep 1 - done - if [ ${device_gone} -eq 0 ]; then - ${debug} echo " failed" - echo "Please destroy VBD ${vbd_uuid} manually." - else - ${XE} vbd-destroy uuid="${vbd_uuid}" - fi - fi + ${debug} echo -n "Destroying VBD: " + ${XE} vbd-destroy uuid="${vbd_uuid}" fi if [ ${fs_uninitialised} -eq 1 -a -n "${vdi_uuid}" ] ; then ${XE} vdi-destroy uuid="${vdi_uuid}" fi } -# if we can't validate the UUID of the VDI, prompt the user -if [ -n "${vdi_uuid}" ]; then - if ! validate_vdi_uuid "${sr_uuid}" "${vdi_uuid}" && [ "$yes" -eq 0 ]; then - echo "Backup VDI $vdi_uuid was most likley create by an earlier" - echo "version of this code. Make sure this is a VDI that you" - echo "created as we can't validate it without mounting it." - read -p "Continue? [Y/N]" -n 1 -r; echo - if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi - fi -fi - echo "Using SR: ${sr_name}" if [ -z "${vdi_uuid}" ]; then if [ "${create_vdi}" -gt 0 ]; then diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 093cd772192..5968dc102e8 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -2,6 +2,14 @@ # Script which restores metadata into a VDI # Citrix Systems Inc, 2008 +function file_exists() { + local out + out="$(debugfs -R "stat $2" "$1" 2>/dev/null | head -n1 | grep "Type: regular")" + if [ -n "${out}" ]; then + echo y + fi +} + if [ ! -e @INVENTORY@ ]; then echo Must run on a XAPI host. exit 1 @@ -27,11 +35,11 @@ default_restore_mode="all" debug="/bin/true" function usage { - echo "Usage: $0 [-h] [-v] [-y] [-n] [-p] [-f] [-x ] [-u ] [-m all|sr]" + echo "Usage: $0 [-h] [-v] [-y] [-n] [-p] [-f] [-o] [-x ] [-u ] [-m all|sr]" echo echo " -h: Display this help message" echo " -x: Specify the VDI UUID to override probing" - echo " -p: Just scan for a metadata VDI and print out its UUID to stdout" + echo " -p: Just scan for metadata VDI(s) and print out UUID(s) to stdout" echo " -u: UUID of the SR you wish to restore from" echo " -n: Perform a dry run of the metadata import commands (default: false)" echo " -l: Just list the available backup dates" @@ -40,6 +48,7 @@ function usage { echo " -v: Verbose output" echo " -y: Assume non-interactive mode and yes to all questions" echo " -f: Forcibly restore VM metadata, dangerous due to its destructive nature, please always do a dry run before using this (default: false)" + echo " -o: Allow use of legacy backup VDIs (this should not be used with SRs with untrusted VDIs)" echo exit 1 } @@ -67,7 +76,9 @@ just_probe=0 chosen_date="" restore_mode=${default_restore_mode} force=0 -while getopts "yhpvx:d:lnu:m:f" opt ; do +legacy=0 +specified_vdi= +while getopts "yhpvx:d:lnu:m:fo" opt ; do case $opt in h) usage ;; u) sr_uuid=${OPTARG} ;; @@ -77,9 +88,10 @@ while getopts "yhpvx:d:lnu:m:f" opt ; do v) debug="" ;; d) chosen_date=${OPTARG} ;; m) restore_mode=${OPTARG} ;; - x) vdis=${OPTARG} ;; + x) specified_vdi=${OPTARG} ;; y) yes=1 ;; f) force=1 ;; + o) legacy=1 ;; *) echo "Invalid option"; usage ;; esac done @@ -110,16 +122,75 @@ sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label) # probe first for a VDI with known UUID derived from the SR to avoid # scanning for a VDI backup_vdi=$(uuid5 "${NS}" "${sr_uuid}") -if [ -z "${vdis}" ]; then - vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal) + +# Only allow a specified VDI that does not match the known UUID if operating in +# legacy mode +if [ -n "${specified_vdi}" ]; then + if [ "${specified_vdi}" != "${backup_vdi}" ] && [ "$legacy" -eq 0 ]; then + echo "The specified VDI UUID is not permitted, if attempting to use a legacy backup VDI please use the -o flag" >&2 + exit 1 + fi + vdis=${specified_vdi} fi -# get a list of all VDIs if an override has not been provided on the cmd line if [ -z "${vdis}" ]; then - vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal) + if [ "$legacy" -eq 0 ]; then + # In non-legacy mode, only use the known backup_vdi UUID + vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal) + else + # In legacy mode, scan all VDIs + vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal) + fi fi mnt= +vdi_uuid= +vbd_uuid= +device= +function createvbd { + ${debug} echo -n "Creating VBD: " >&2 + vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null) + + if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then + ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2 + cleanup + return 1 + fi + + ${debug} echo "${vbd_uuid}" >&2 + + ${debug} echo -n "Plugging VBD: " >&2 + ${XE} vbd-plug uuid="${vbd_uuid}" + device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device) + + if [ ! -b "${device}" ]; then + ${debug} echo "${device}: not a block special" >&2 + cleanup + return 1 + fi + + ${debug} echo "${device}" >&2 + return 0 +} + +function mountvbd { + mnt="/var/run/pool-backup-${vdi_uuid}" + mkdir -p "${mnt}" + /sbin/fsck -a "${device}" >/dev/null 2>&1 + if [ $? -ne 0 ]; then + echo "File system integrity error. Please correct manually." >&2 + cleanup + return 1 + fi + mount "${device}" "${mnt}" >/dev/null 2>&1 + if [ $? -ne 0 ]; then + ${debug} echo failed >&2 + cleanup + return 1 + fi + return 0 +} + function cleanup { cd / if [ ! -z "${mnt}" ]; then @@ -131,95 +202,42 @@ function cleanup { if [ ! -z "${vbd_uuid}" ]; then ${debug} echo -n "Unplugging VBD: " >&2 ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20 - # poll for the device to go away if we know its name - if [ "${device}" != "" ]; then - device_gone=0 - for ((i=0; i<10; i++)); do - ${debug} echo -n "." >&2 - if [ ! -b "${device}" ]; then - ${debug} echo " done" >&2 - device_gone=1 - break - fi - sleep 1 - done - if [ ${device_gone} -eq 0 ]; then - ${debug} echo " failed" >&2 - ${debug} echo "Please destroy VBD ${vbd_uuid} manually." >&2 - else - ${XE} vbd-destroy uuid="${vbd_uuid}" - vbd_uuid="" - fi - fi + ${debug} echo -n "Destroying VBD: " >&2 + ${XE} vbd-destroy uuid="${vbd_uuid}" + vbd_uuid="" device="" fi } if [ -z "${vdis}" ]; then echo "No VDIs found on SR." >&2 + if [ "$legacy" -eq 0 ]; then + echo "If you believe there may be a legacy backup VDI present, you can use the -o flag to search for it (this should not be used with untrusted VDIs)" >&2 + fi exit 0 fi trap cleanup SIGINT ERR +declare -a matched_vdis for vdi_uuid in ${vdis}; do - if [ "${vdi_uuid}" != "${backup_vdi}" ] && [ "$yes" -eq 0 ]; then - echo "Probing VDI ${vdi_uuid}." - echo "This VDI was created with a prior version of this code." - echo "Its validity can't be checked without mounting it first." - read -p "Continue? [Y/N]" -n 1 -r; echo - if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi - fi - - ${debug} echo -n "Creating VBD: " >&2 - vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null) - - if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then - ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2 - cleanup - continue - fi - - ${debug} echo "${vbd_uuid}" >&2 - - ${debug} echo -n "Plugging VBD: " >&2 - ${XE} vbd-plug uuid="${vbd_uuid}" - device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device) - - if [ ! -b "${device}" ]; then - ${debug} echo "${device}: not a block special" >&2 - cleanup + createvbd + if [ $? -ne 0 ]; then continue fi - ${debug} echo "${device}" >&2 - ${debug} echo -n "Probing device: " >&2 - probecmd="@LIBEXECDIR@/probe-device-for-file" - metadata_stamp="/.ctxs-metadata-backup" mnt= - ${probecmd} "${device}" "${metadata_stamp}" - if [ $? -eq 0 ]; then + if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 - mnt="/var/run/pool-backup-${vdi_uuid}" - mkdir -p "${mnt}" - /sbin/fsck -a "${device}" >/dev/null 2>&1 - if [ $? -ne 0 ]; then - echo "File system integrity error. Please correct manually." >&2 - cleanup + if ! mountvbd; then continue fi - mount "${device}" "${mnt}" >/dev/null 2>&1 - if [ $? -ne 0 ]; then - ${debug} echo failed >&2 - cleanup - else - if [ -e "${mnt}/.ctxs-metadata-backup" ]; then - ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 - xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true - break - fi + + if [ -e "${mnt}/.ctxs-metadata-backup" ]; then + ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 + matched_vdis+=( "${vdi_uuid}" ) fi else ${debug} echo "backup metadata not found" >&2 @@ -228,11 +246,33 @@ for vdi_uuid in ${vdis}; do done if [ $just_probe -gt 0 ]; then - echo "${vdi_uuid}" - cleanup + for vdi_uuid in "${matched_vdis[@]}"; do + echo "${vdi_uuid}" + done exit 0 fi +if [ "${#matched_vdis[@]}" -eq 0 ]; then + echo "Metadata backups not found." >&2 + exit 1 +fi + +if [ "${#matched_vdis[@]}" -gt 1 ]; then + echo "Multiple metadata backups found, please use -x to specify the VDI UUID to use" >&2 + exit 1 +fi + +vdi_uuid=${matched_vdis[0]} +xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true +if ! createvbd; then + echo "Failure creating VBD for backup VDI ${vdi_uuid}" >&2 + exit 1 +fi +if ! mountvbd; then + echo "Failure mounting backup VDI ${vdi_uuid}" >&2 + exit 1 +fi + cd "${mnt}" ${debug} echo "" >&2 @@ -319,9 +359,10 @@ else fi shopt -s nullglob for meta in *.vmmeta; do - echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}" - "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}" - if [ $? -gt 0 ]; then + # shellcheck disable=SC2086 + echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} + # shellcheck disable=SC2086 + if ! "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag}; then error_count=$(( $error_count + 1 )) else good_count=$(( $good_count + 1 )) diff --git a/unixpwd/src/dune b/unixpwd/src/dune index a699b846e5d..e853925e0a6 100644 --- a/unixpwd/src/dune +++ b/unixpwd/src/dune @@ -1,5 +1,6 @@ (library (name unixpwd) + (modes best) (libraries unixpwd_stubs ) diff --git a/vhd-format-lwt.opam b/vhd-format-lwt.opam index 49acf611147..e89b1cfdc7c 100644 --- a/vhd-format-lwt.opam +++ b/vhd-format-lwt.opam @@ -16,7 +16,7 @@ tags: ["org:mirage" "org:xapi-project"] homepage: "https://github.com/mirage/ocaml-vhd" bug-reports: "https://github.com/mirage/ocaml-vhd/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.02.3" & < "5.0.0"} "alcotest" {with-test} "alcotest-lwt" {with-test} diff --git a/vhd-tool.opam b/vhd-tool.opam index c1f8135c98d..f0135ab7a41 100644 --- a/vhd-tool.opam +++ b/vhd-tool.opam @@ -1,25 +1,20 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "Manipulate .vhd files" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +tags: ["org.mirage" "org:xapi-project"] +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ - "org:mirage" - "org:xapi-project" -] -build: [[ "dune" "build" "-p" name "-j" jobs ] -] depends: [ - "ocaml" - "dune" + "dune" {>= "3.15"} "alcotest-lwt" {with-test} "cohttp-lwt" "conf-libssl" "cstruct" {>= "3.0.0"} - "forkexec" + "ezxenstore" {= version} + "forkexec" {= version} "io-page" "lwt" "nbd-unix" @@ -29,14 +24,27 @@ depends: [ "rpclib" "sha" "tar" - "vhd-format" - "vhd-format-lwt" - "xapi-idl" - "xapi-log" + "vhd-format" {= version} + "vhd-format-lwt" {= version} + "xapi-idl" {= version} + "xapi-log" {= version} + "xen-api-client-lwt" {= version} "xenstore" "xenstore_transport" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -synopsis: ".vhd file manipulation" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/vhd-tool.opam.template b/vhd-tool.opam.template deleted file mode 100644 index 52cf0e72d43..00000000000 --- a/vhd-tool.opam.template +++ /dev/null @@ -1,40 +0,0 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ - "org:mirage" - "org:xapi-project" -] -build: [[ "dune" "build" "-p" name "-j" jobs ] -] -depends: [ - "ocaml" - "dune" - "alcotest-lwt" {with-test} - "cohttp-lwt" - "conf-libssl" - "cstruct" {>= "3.0.0"} - "forkexec" - "io-page" - "lwt" - "nbd-unix" - "ppx_cstruct" - "ppx_deriving_rpc" - "re" - "rpclib" - "sha" - "tar" - "vhd-format" - "vhd-format-lwt" - "xapi-idl" - "xapi-log" - "xenstore" - "xenstore_transport" -] -synopsis: ".vhd file manipulation" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/wsproxy.opam b/wsproxy.opam index 9e9def30a82..0d9e79c096c 100644 --- a/wsproxy.opam +++ b/wsproxy.opam @@ -7,7 +7,7 @@ license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "base64" {>= "3.1.0"} "fmt" diff --git a/xapi-forkexecd.opam b/xapi-forkexecd.opam index 900419be134..6f2ccbffdb8 100644 --- a/xapi-forkexecd.opam +++ b/xapi-forkexecd.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "astring" "forkexec" {= version} "uuid" {= version} diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 595478821f2..ef37bd16486 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "base-threads" diff --git a/xapi-rrd-transport-utils.opam b/xapi-rrd-transport-utils.opam index 261da91a4e3..754b956f157 100644 --- a/xapi-rrd-transport-utils.opam +++ b/xapi-rrd-transport-utils.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" "cmdliner" "rrd-transport" {= version} diff --git a/xapi-rrdd.opam b/xapi-rrdd.opam index 0782309fe06..745af249f4b 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.opam @@ -9,9 +9,8 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.02.0"} - "dune-build-info" "alcotest" {with-test} "astring" "gzip" {= version} diff --git a/xapi-sdk.opam b/xapi-sdk.opam index 93dbd1d640a..b09d4c60808 100644 --- a/xapi-sdk.opam +++ b/xapi-sdk.opam @@ -7,7 +7,7 @@ license: "BSD-2-Clause" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "mustache" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index ee8aa096ab2..06021447900 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "clock" {= version} "ptime" "odoc" {with-doc} diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index c0f8c27c5e7..bed359bb9e0 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.13.0"} "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 83f4f2da1da..bfab6d693b3 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "logs" "odoc" {with-doc} diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 4cee75aac36..753fcd696d1 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.08.0"} "alcotest" {with-test} "odoc" {with-doc} diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 4adef00e43e..eba91836d0f 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "base-threads" "base-unix" "odoc" {with-doc} diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index e154fe829da..4daa2eb9326 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.12.0"} "alcotest" {with-test} "base-unix" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 6b6dfc62f9b..d20671b901b 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "odoc" {with-doc} ] build: [ diff --git a/xapi-tracing-export.opam b/xapi-tracing-export.opam index 4ec270f6328..fb00c67bc06 100644 --- a/xapi-tracing-export.opam +++ b/xapi-tracing-export.opam @@ -11,7 +11,7 @@ bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "ocaml" "cohttp-posix" - "dune" {>= "3.0"} + "dune" {>= "3.15"} "cohttp" "rpclib" "ppx_deriving_rpc" diff --git a/xapi-tracing.opam b/xapi-tracing.opam index f2dbbd2b132..a2ae1016cea 100644 --- a/xapi-tracing.opam +++ b/xapi-tracing.opam @@ -10,7 +10,7 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "ocaml" - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "re" "uri" diff --git a/xapi.opam b/xapi.opam index 387ba542fe6..6f67cf1c1f3 100644 --- a/xapi.opam +++ b/xapi.opam @@ -1,20 +1,18 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "The toolstack daemon which implements the XenAPI" +description: + "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] depends: [ - "ocaml" - "dune" - "alcotest" # needed to generate the quicktest binary + "dune" {>= "3.15"} + "alcotest" "angstrom" + "base-threads" "base64" "cdrom" "conf-pam" @@ -22,56 +20,71 @@ depends: [ "ctypes" "ctypes-foreign" "domain-name" - "ezxenstore" + "ezxenstore" {= version} "fmt" {with-test} "hex" - "http-lib" {with-test} # the public library is only used for testing + "http-lib" {with-test & = version} "ipaddr" - "mirage-crypto" {with-test} + "mirage-crypto" "mirage-crypto-pk" - "mirage-crypto-rng" {with-test} - "message-switch-unix" + "mirage-crypto-rng" {>= "0.11.0"} + "message-switch-unix" {= version} "mtime" "opentelemetry-client-ocurl" "pci" - "pciutil" + "pciutil" {= version} "ppx_deriving_rpc" "ppx_sexp_conv" "ppx_deriving" "psq" "rpclib" - "rrdd-plugin" + "rrdd-plugin" {= version} "rresult" "sexpr" "sha" - "stunnel" + "stunnel" {= version} "tar" "tar-unix" - "base-threads" - "base-unix" - "uuid" + "uuid" {= version} "x509" - "xapi-client" - "xapi-cli-protocol" - "xapi-consts" - "xapi-datamodel" - "xapi-expiry-alerts" - "xapi-stdext-date" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" + "xapi-client" {= version} + "xapi-cli-protocol" {= version} + "xapi-consts" {= version} + "xapi-datamodel" {= version} + "xapi-expiry-alerts" {= version} + "xapi-idl" {= version} + "xapi-inventory" {= version} + "xapi-log" {= version} + "xapi-stdext-date" {= version} + "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} + "xapi-stdext-threads" {= version} + "xapi-stdext-unix" {= version} + "xapi-stdext-zerocheck" {= version} "xapi-test-utils" {with-test} - "xapi-tracing" - "xapi-types" - "xapi-xenopsd" - "xapi-idl" - "xapi-inventory" - "xml-light2" + "xapi-tracing" {= version} + "xapi-types" {= version} + "xapi-xenopsd" {= version} + "xml-light2" {= version} "yojson" - "zstd" + "zstd" {= version} + "odoc" {with-doc} ] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} @@ -79,10 +92,3 @@ depexts: [ ["hwdata" "xxhash-devel" "xxhash-libs"] {os-distribution = "fedora"} ["hwdata" "xxhash-dev" "xxhash"] {os-distribution = "alpine"} ] -synopsis: "The xapi toolstack daemon which implements the XenAPI" -description: """ -This daemon exposes the XenAPI and is used by clients such as 'xe' -and 'XenCenter' to manage clusters of Xen-enabled hosts.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/xapi.opam.template b/xapi.opam.template index 49f3902f66a..3dea8527e92 100644 --- a/xapi.opam.template +++ b/xapi.opam.template @@ -1,75 +1,3 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "ocaml" - "dune" - "alcotest" # needed to generate the quicktest binary - "angstrom" - "base64" - "cdrom" - "conf-pam" - "crowbar" {with-test} - "ctypes" - "ctypes-foreign" - "domain-name" - "ezxenstore" - "fmt" {with-test} - "hex" - "http-lib" {with-test} # the public library is only used for testing - "ipaddr" - "mirage-crypto" {with-test} - "mirage-crypto-pk" - "mirage-crypto-rng" {with-test} - "message-switch-unix" - "mtime" - "opentelemetry-client-ocurl" - "pci" - "pciutil" - "ppx_deriving_rpc" - "ppx_sexp_conv" - "ppx_deriving" - "psq" - "rpclib" - "rrdd-plugin" - "rresult" - "sexpr" - "sha" - "stunnel" - "tar" - "tar-unix" - "base-threads" - "base-unix" - "uuid" - "x509" - "xapi-client" - "xapi-cli-protocol" - "xapi-consts" - "xapi-datamodel" - "xapi-expiry-alerts" - "xapi-stdext-date" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" - "xapi-test-utils" {with-test} - "xapi-tracing" - "xapi-types" - "xapi-xenopsd" - "xapi-idl" - "xapi-inventory" - "xml-light2" - "yojson" - "zstd" -] depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} @@ -77,10 +5,3 @@ depexts: [ ["hwdata" "xxhash-devel" "xxhash-libs"] {os-distribution = "fedora"} ["hwdata" "xxhash-dev" "xxhash"] {os-distribution = "alpine"} ] -synopsis: "The xapi toolstack daemon which implements the XenAPI" -description: """ -This daemon exposes the XenAPI and is used by clients such as 'xe' -and 'XenCenter' to manage clusters of Xen-enabled hosts.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/xen-api-client.opam b/xen-api-client.opam index 3c31159d66c..75773851324 100644 --- a/xen-api-client.opam +++ b/xen-api-client.opam @@ -15,8 +15,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} - "dune-build-info" + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "cohttp" {>= "0.22.0"}