diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index aca7f00f4a6..4d0350056f3 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -28,14 +28,13 @@ jobs: run: sudo apt-get update - name: Use ocaml - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true opam-pin: false - opam-depext: false - name: Install ocamlformat run: opam install ocamlformat diff --git a/.github/workflows/setup-xapi-environment/action.yml b/.github/workflows/setup-xapi-environment/action.yml index a7890222498..72700599cf2 100644 --- a/.github/workflows/setup-xapi-environment/action.yml +++ b/.github/workflows/setup-xapi-environment/action.yml @@ -45,12 +45,13 @@ runs: # We set DUNE_CACHE_STORAGE_MODE, it is required for dune cache to work inside opam for now, # otherwise it gets EXDEV and considers it a cache miss - name: Use ocaml - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true + opam-pin: false env: DUNE_CACHE_STORAGE_MODE: copy 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..0efbe491956 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,69 @@ (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 + qcheck-alcotest + 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 +385,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 +528,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/markdown_backend.ml b/ocaml/idl/markdown_backend.ml index e039a7cfc42..66110b7d694 100644 --- a/ocaml/idl/markdown_backend.ml +++ b/ocaml/idl/markdown_backend.ml @@ -43,8 +43,6 @@ let compare_case_ins x y = compare (String.lowercase_ascii x) (String.lowercase_ascii y) let escape s = - let open Xapi_stdext_std.Xstringext in - let sl = String.explode s in let esc_char = function | '\\' -> "\" @@ -79,8 +77,7 @@ let escape s = | c -> String.make 1 c in - let escaped_list = List.map esc_char sl in - String.concat "" escaped_list + String.to_seq s |> Seq.map esc_char |> List.of_seq |> String.concat "" let rec of_ty_verbatim = function | SecretString | String -> 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..76285033f35 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,21 @@ ) ) +(library + (name test_timer) + (modules test_timer) + (libraries + alcotest + clock + fmt + mtime.clock.os + 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..f6de65dbe48 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,17 +91,15 @@ rresult http_lib qcheck-core - qcheck-core.runner xapi_fd_test ) - ; use fixed seed to avoid causing random failures in CI and package builds - (action (run %{test} -v -bt --seed 42)) ) (rule (alias stresstest) + (deps bufio_test_run.exe) ; use default random seed on stresstests - (action (run %{dep:bufio_test.exe} -v -bt)) + (action (run %{deps} -v -bt)) ) (executable @@ -97,7 +107,7 @@ (name test_client) (modules test_client) (libraries - dune-build-info + http_lib safe-resources stunnel @@ -112,7 +122,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..c2f7e2aeda8 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -24,8 +24,6 @@ exception Forbidden exception Method_not_implemented -exception Malformed_url of string - exception Timeout exception Too_large @@ -94,6 +92,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" @@ -138,61 +143,8 @@ let output_http fd headers = |> String.concat "" |> Unixext.really_write_string fd -let explode str = Astring.String.fold_right (fun c acc -> c :: acc) str [] - -let implode chr_list = - String.concat "" (List.map Astring.String.of_char chr_list) - -let urldecode url = - let chars = explode url in - let rec fn ac = function - | '+' :: tl -> - fn (' ' :: ac) tl - | '%' :: a :: b :: tl -> - let cs = - try int_of_string (implode ['0'; 'x'; a; b]) - with _ -> raise (Malformed_url url) - in - fn (Char.chr cs :: ac) tl - | x :: tl -> - fn (x :: ac) tl - | [] -> - implode (List.rev ac) - in - fn [] chars - (* Encode @param suitably for appearing in a query parameter in a URL. *) -let urlencode param = - let chars = explode param in - let rec fn = function - | x :: tl -> - let s = - if x = ' ' then - "+" - else - match x with - | 'A' .. 'Z' - | 'a' .. 'z' - | '0' .. '9' - | '$' - | '-' - | '_' - | '.' - | '!' - | '*' - | '\'' - | '(' - | ')' - | ',' -> - Astring.String.of_char x - | _ -> - Printf.sprintf "%%%2x" (Char.code x) - in - s ^ fn tl - | [] -> - "" - in - fn chars +let urlencode param = Uri.pct_encode ~component:`Query param (** Parses strings of the form a=b;c=d (new, RFC-compliant cookie format) and a=b&c=d (old, incorrect style) into [("a", "b"); ("c", "d")] *) @@ -212,7 +164,7 @@ let parse_cookies xs = List.map (function | k :: vs -> - (urldecode k, urldecode (String.concat "=" vs)) + (Uri.pct_decode k, Uri.pct_decode (String.concat "=" vs)) | [] -> raise Http_parse_failure ) @@ -916,7 +868,7 @@ module Url = struct in let data = { - uri= (match Uri.path uri with "" -> "/" | path -> path) + uri= (match Uri.path_unencoded uri with "" -> "/" | path -> path) ; query_params= Uri.query uri |> List.map query } in @@ -929,7 +881,7 @@ module Url = struct | Some "https" -> (scheme ~ssl:true, data) | Some "file" -> - let scheme = File {path= Uri.path uri} in + let scheme = File {path= Uri.path_unencoded uri} in (scheme, {data with uri= "/"}) | _ -> failwith "unsupported URI scheme" diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 687c4d2f8c7..91590bcdcdd 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 *) @@ -233,6 +235,7 @@ val output_http : Unix.file_descr -> string list -> unit val parse_cookies : string -> (string * string) list val urlencode : string -> string +(** Encode parameter suitably for appearing in a query parameter in a URL. *) type 'a ll = End | Item of 'a * (unit -> 'a ll) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index d8718bd68a6..7c270874a96 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 @@ -377,7 +374,7 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) let uri_t = Uri.of_string uri in if uri_t = Uri.empty then raise Http_parse_failure ; - let uri = Uri.path uri_t |> Uri.pct_decode in + let uri = Uri.path_unencoded uri_t in let query = Uri.query uri_t |> kvlist_flatten in let m = Http.method_t_of_string meth in let version = 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/open-uri/open_uri.ml b/ocaml/libs/open-uri/open_uri.ml index 84cbd3b6ab5..2e3cda05413 100644 --- a/ocaml/libs/open-uri/open_uri.ml +++ b/ocaml/libs/open-uri/open_uri.ml @@ -74,7 +74,7 @@ let with_open_uri ?verify_cert uri f = ) ) | Some "file" -> - let filename = Uri.path_and_query uri in + let filename = Uri.path_and_query uri |> Uri.pct_decode in let sockaddr = Unix.ADDR_UNIX filename in let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in finally 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-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml index e89cefba3da..c290ab8e569 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -208,4 +208,15 @@ module List = struct let find_minimum compare = let min a b = if compare a b <= 0 then a else b in function [] -> None | x :: xs -> Some (List.fold_left min x xs) + + let find_index f l = + let rec loop i = function + | [] -> + None + | x :: _ when f x -> + Some i + | _ :: xs -> + loop (i + 1) xs + in + loop 0 l end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli index d836c751230..231c3891060 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -60,6 +60,13 @@ module List : sig the sort order of [cmp], or [None] if the list is empty. When two ore more elements match the lowest value, the left-most is returned. *) + val find_index : ('a -> bool) -> 'a list -> int option + (** [find_index f l] returns the position of the first element in [l] that + satisfies [f x]. If there is no such element, returns [None]. + + When using OCaml compilers 5.1 or later, please use the standard library + instead. *) + (** {1 Using indices to manipulate lists} *) val chop : int -> 'a list -> 'a list * 'a list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml index 7fb16aba6f8..0b3da00c476 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml @@ -39,10 +39,6 @@ module String = struct done ; !accu - let explode string = fold_right (fun h t -> h :: t) string [] - - let implode list = concat "" (List.map of_char list) - (** True if string 'x' ends with suffix 'suffix' *) let endswith suffix x = let x_l = String.length x and suffix_l = String.length suffix in @@ -56,16 +52,6 @@ module String = struct (** Returns true for whitespace characters, false otherwise *) let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false - (** Removes all the characters from the ends of a string for which the predicate is true *) - let strip predicate string = - let rec remove = function - | [] -> - [] - | c :: cs -> - if predicate c then remove cs else c :: cs - in - implode (List.rev (remove (List.rev (remove (explode string))))) - let escaped ?rules string = match rules with | None -> @@ -81,24 +67,28 @@ module String = struct in concat "" (fold_right aux string []) - (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true (excluding those characters from the result) *) let split_f p str = - let not_p x = not (p x) in - let rec split_one p acc = function - | [] -> - (List.rev acc, []) - | c :: cs -> - if p c then split_one p (c :: acc) cs else (List.rev acc, c :: cs) + let split_one seq = + let not_p c = not (p c) in + let a = Seq.take_while not_p seq in + let b = Seq.drop_while not_p seq in + (a, b) in - let rec alternate acc drop chars = - if chars = [] then + let drop seq = Seq.drop_while p seq in + let rec split acc chars = + if Seq.is_empty chars then acc else - let a, b = split_one (if drop then p else not_p) [] chars in - alternate (if drop then acc else a :: acc) (not drop) b + let a, b = split_one chars in + let b = drop b in + let acc = if Seq.is_empty a then acc else Seq.cons a acc in + split acc b in - List.rev (List.map implode (alternate [] true (explode str))) + String.to_seq str + |> split Seq.empty + |> Seq.map String.of_seq + |> List.of_seq + |> List.rev let index_opt s c = let rec loop i = diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli index e2587929916..e2b486285a6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli @@ -29,12 +29,6 @@ module String : sig val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a (** Iterate over the characters in a string in reverse order. *) - val explode : string -> char list - (** Split a string into a list of characters. *) - - val implode : char list -> string - (** Concatenate a list of characters into a string. *) - val endswith : string -> string -> bool (** True if string 'x' ends with suffix 'suffix' *) @@ -44,9 +38,6 @@ module String : sig val isspace : char -> bool (** True if the character is whitespace *) - val strip : (char -> bool) -> string -> string - (** Removes all the characters from the ends of a string for which the predicate is true *) - val escaped : ?rules:(char * string) list -> string -> string (** Backward-compatible string escaping, defaulting to the built-in OCaml string escaping but allowing an arbitrary mapping from characters @@ -54,7 +45,8 @@ module String : sig val split_f : (char -> bool) -> string -> string list (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true *) + runs of characters where the predicate was true. Avoid if possible, it's + very costly to execute. *) val split : ?limit:int -> char -> string -> string list (** split a string on a single char *) 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..0eb42f9d114 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,16 +1,23 @@ -(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)) ) (rule (alias stresstest) + (deps unixext_test_run.exe) ; use default random seed on stresstests - (action (run %{dep:unixext_test.exe} -v -bt)) + (action (run %{deps} -v -bt)) ) (test diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t index 33b39dc277c..28790e8a32d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t @@ -15,8 +15,7 @@ == Use socket files $ export TMPDIR=${TMPDIR:-/tmp} - $ export XDG_RUNTIME_DIR=${XDG_RUNTIME_DIR:-$TMPDIR} - $ export NOTIFY_SOCKET="${XDG_RUNTIME_DIR}/systemd.socket" + $ export NOTIFY_SOCKET="${TMPDIR}/systemd.socket" $ rm -f "$NOTIFY_SOCKET" $ ./test_systemd.exe --server & READY=1 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/switch/switch_main.ml b/ocaml/message-switch/switch/switch_main.ml index 583baf6e594..7fb907d1cb2 100644 --- a/ocaml/message-switch/switch/switch_main.ml +++ b/ocaml/message-switch/switch/switch_main.ml @@ -222,7 +222,7 @@ let make_server config trace_config = let open Message_switch_core.Protocol in Cohttp_lwt.Body.to_string body >>= fun body -> let uri = Cohttp.Request.uri req in - let path = Uri.path uri in + let path = Uri.path_unencoded uri in match In.of_request body (Cohttp.Request.meth req) path with | None -> error "<- [unparsable request; path = %s; body = %s]" path 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/nbd/src/main.ml b/ocaml/nbd/src/main.ml index d8f67a8c49a..25919464839 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -59,7 +59,7 @@ let handle_connection fd tls_role = >>= fun session_id -> f uri rpc session_id in let serve t uri rpc session_id = - let path = Uri.path uri in + let path = Uri.path_unencoded uri in (* note preceeding / *) let vdi_uuid = if path <> "" then String.sub path 1 (String.length path - 1) else path 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/createpool.ml b/ocaml/perftest/createpool.ml index ad4207427f6..bf96cfb7c36 100644 --- a/ocaml/perftest/createpool.ml +++ b/ocaml/perftest/createpool.ml @@ -350,24 +350,20 @@ let create_sdk_pool session_id sdkname pool_name key ipbase = let pingable = Array.make (Array.length hosts) false in let firstboot = Array.make (Array.length hosts) false in let string_of_status () = - Xstringext.String.implode - (Array.to_list - (Array.mapi - (fun i ping -> - let boot = firstboot.(i) in - match (ping, boot) with - | false, false -> - '.' - | true, false -> - 'P' - | true, true -> - 'B' - | _, _ -> - '?' - ) - pingable - ) - ) + Array.to_seq pingable + |> Seq.mapi (fun i ping -> + let boot = firstboot.(i) in + match (ping, boot) with + | false, false -> + '.' + | true, false -> + 'P' + | true, true -> + 'B' + | _, _ -> + '?' + ) + |> String.of_seq in let has_guest_booted i _vm = let ip = Printf.sprintf "192.168.%d.%d" pool.ipbase (i + 1) in @@ -469,24 +465,20 @@ let create_sdk_pool session_id sdkname pool_name key ipbase = let live = Array.make (Array.length hosts) false in let enabled = Array.make (Array.length hosts) false in let string_of_status () = - Xstringext.String.implode - (Array.to_list - (Array.mapi - (fun i live -> - let enabled = enabled.(i) in - match (live, enabled) with - | false, false -> - '.' - | true, false -> - 'L' - | true, true -> - 'E' - | _, _ -> - '?' - ) - live - ) - ) + Array.to_seq live + |> Seq.mapi (fun i live -> + let enabled = enabled.(i) in + match (live, enabled) with + | false, false -> + '.' + | true, false -> + 'L' + | true, true -> + 'E' + | _, _ -> + '?' + ) + |> String.of_seq in let has_host_booted rpc session_id i host = try 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/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java index 20d6e5efc8e..9d1389eaf28 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java @@ -216,6 +216,7 @@ private void initializeObjectMapperConfiguration() { dateHandlerModule.addDeserializer(Date.class, new CustomDateDeserializer()); this.objectMapper.enable(JsonReadFeature.ALLOW_NON_NUMERIC_NUMBERS.mappedFeature()); this.objectMapper.configure(DeserializationFeature.FAIL_ON_UNKNOWN_PROPERTIES, false); + this.objectMapper.configure(DeserializationFeature.READ_UNKNOWN_ENUM_VALUES_USING_DEFAULT_VALUE, true); this.objectMapper.registerModule(dateHandlerModule); } 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/java/main.ml b/ocaml/sdk-gen/java/main.ml index 3edcf1ea3a2..483d8689db1 100644 --- a/ocaml/sdk-gen/java/main.ml +++ b/ocaml/sdk-gen/java/main.ml @@ -882,7 +882,7 @@ let gen_enum file name ls = ) ls ; fprintf file " /* This can never be reached */\n" ; - fprintf file " return \"illegal enum\";\n" ; + fprintf file " return \"UNRECOGNIZED\";\n" ; fprintf file " }\n" ; fprintf file "\n }\n\n" 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 831cc02ff87..0b3c93ed3ca 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_xapi_helpers + test_ref test_xapi_helpers 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/tests/testauthx.ml b/ocaml/tests/testauthx.ml index 8d0856101bb..2632ef8b919 100644 --- a/ocaml/tests/testauthx.ml +++ b/ocaml/tests/testauthx.ml @@ -20,19 +20,22 @@ let usage () = exit 1 let _ = + let __context = Context.make __MODULE__ in if Array.length Sys.argv <> 3 then usage () ; let username = Sys.argv.(1) and password = Sys.argv.(2) in let hr x = print_endline ("-----------------------------\n" ^ x) in (* should return 2037 *) hr ("TEST 1a. Authx.get_subject_identifier " ^ username) ; - let userid = AuthX.methods.get_subject_identifier username in + let userid = AuthX.methods.get_subject_identifier ~__context username in print_endline ("userid=" ^ userid) ; hr ("TEST 1b. AuthX.methods.get_subject_identifier " ^ username ^ "_werq (unknown subject)" ) ; - try print_endline (AuthX.methods.get_subject_identifier (username ^ "_werq")) + try + print_endline + (AuthX.methods.get_subject_identifier ~__context (username ^ "_werq")) with Not_found -> ( print_endline "subject Not_found, as expected" ; (* should return a list of groups that subjectid 1000 (a user) belongs to *) @@ -42,7 +45,7 @@ let _ = ^ " (a user subject)" ) ; let conc x y = x ^ "," ^ y in - let groupid_list = AuthX.methods.query_group_membership userid in + let groupid_list = AuthX.methods.query_group_membership ~__context userid in print_endline (List.fold_left conc "" groupid_list) ; (* should return a list of groups that subjectid 10024 (a group) belongs to *) let agroup = List.hd groupid_list in @@ -52,23 +55,31 @@ let _ = ^ " (a group subject)" ) ; print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership agroup)) ; + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context agroup) + ) ; hr "TEST 2c. AuthX.methods.query_group_membership u999 (unknown subject)" ; try print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership "u999")) + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context "u999") + ) with Not_found -> ( print_endline "subject Not_found, as expected." ; hr "TEST 2d. AuthX.methods.query_group_membership a999 (unknown subject)" ; try print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership "a999")) + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context "a999") + ) with Not_found -> ( print_endline "subject Not_found, as expected." ; hr "TEST 2e. AuthX.methods.query_group_membership 999 (unknown subject)" ; try print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership "999")) + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context "999") + ) with Not_found -> ( print_endline "subject Not_found, as expected." ; (* should return a list with information about subject_id 1000 (a user)*) @@ -77,7 +88,9 @@ let _ = ^ userid ^ " (a user)" ) ; - let infolist1 = AuthX.methods.query_subject_information userid in + let infolist1 = + AuthX.methods.query_subject_information ~__context userid + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -88,7 +101,9 @@ let _ = ^ agroup ^ " (a group)" ) ; - let infolist1 = AuthX.methods.query_subject_information agroup in + let infolist1 = + AuthX.methods.query_subject_information ~__context agroup + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -98,7 +113,9 @@ let _ = "TEST 3c. AuthX.methods.query_subject_information u999 (unknown \ subject)" ; try - let infolist1 = AuthX.methods.query_subject_information "u999" in + let infolist1 = + AuthX.methods.query_subject_information ~__context "u999" + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -110,7 +127,9 @@ let _ = "TEST 3d. AuthX.methods.query_subject_information a999 (unknown \ subject)" ; try - let infolist1 = AuthX.methods.query_subject_information "a999" in + let infolist1 = + AuthX.methods.query_subject_information ~__context "a999" + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -122,7 +141,9 @@ let _ = "TEST 3e. AuthX.methods.query_subject_information 999 (unknown \ subject)" ; try - let infolist1 = AuthX.methods.query_subject_information "999" in + let infolist1 = + AuthX.methods.query_subject_information ~__context "999" + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -134,8 +155,8 @@ let _ = ^ username ) ; print_endline - (AuthX.methods.authenticate_username_password username - password + (AuthX.methods.authenticate_username_password ~__context + username password ) ) ) 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/dune b/ocaml/vhd-tool/src/dune index dab81d82c24..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) @@ -38,6 +39,9 @@ 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 54058316625..6052e77eb52 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -787,9 +787,9 @@ let endpoint_of_string = function if he = [] then raise Not_found ; return (Sockaddr (List.hd he).Unix.ai_addr) | Some "unix", _ -> - return (Sockaddr (Lwt_unix.ADDR_UNIX (Uri.path uri'))) + return (Sockaddr (Lwt_unix.ADDR_UNIX (Uri.path_unencoded uri'))) | Some "file", _ -> - return (File (Uri.path uri')) + return (File (Uri.path_unencoded uri')) | Some "http", _ -> return (Http uri') | Some "https", _ -> 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/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/lib/server_interface.ml b/ocaml/xapi-guard/lib/server_interface.ml index d58a934f5f2..c6f70769313 100644 --- a/ocaml/xapi-guard/lib/server_interface.ml +++ b/ocaml/xapi-guard/lib/server_interface.ml @@ -77,9 +77,8 @@ let serve_forever_lwt path callback = Lwt.return cleanup let serve_forever_lwt_callback rpc_fn path _ req body = - let uri = Cohttp.Request.uri req in - match (Cohttp.Request.meth req, Uri.path uri) with - | `POST, _ -> + match Cohttp.Request.meth req with + | `POST -> let* body = Cohttp_lwt.Body.to_string body in let* response = Xapi_guard.Dorpc.wrap_rpc err (fun () -> @@ -91,7 +90,7 @@ let serve_forever_lwt_callback rpc_fn path _ req body = in let body = response |> Xmlrpc.string_of_response in Cohttp_lwt_unix.Server.respond_string ~status:`OK ~body () - | _, _ -> + | _ -> let body = "Not allowed" |> Rpc.rpc_of_string @@ -142,7 +141,7 @@ let serve_forever_lwt_callback_vtpm ~cache mutex (read, persist) vm_uuid _ req *) Lwt_mutex.with_lock mutex @@ fun () -> (* TODO: some logging *) - match (Cohttp.Request.meth req, Uri.path uri) with + match (Cohttp.Request.meth req, Uri.path_unencoded uri) with | `GET, path when path <> "/" -> let key = Tpm.key_of_swtpm path in let* body = read (vm_uuid, timestamp, key) in 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/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 69217d8328c..d6c3cae14db 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -501,8 +501,8 @@ let http_handler call_of_string string_of_response process s = | `Invalid x -> debug "Failed to read HTTP request. Got: '%s'" x | `Ok req -> ( - match (Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req)) with - | `POST, _ -> ( + match Cohttp.Request.meth req with + | `POST -> ( let headers = Cohttp.Request.headers req in match Cohttp.Header.get headers "content-length" with | None -> @@ -535,7 +535,7 @@ let http_handler call_of_string string_of_response process s = (fun t -> Response.write_body t response_txt) response oc ) - | _, _ -> + | _ -> let content_length = 0 in let headers = Cohttp.Header.of_list 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/device_number_test.ml b/ocaml/xapi-idl/lib_test/device_number_test.ml index 9105299a16e..fc8d5b210f1 100644 --- a/ocaml/xapi-idl/lib_test/device_number_test.ml +++ b/ocaml/xapi-idl/lib_test/device_number_test.ml @@ -30,7 +30,7 @@ let deprecated = let examples_to_test = let using_deprecated_ide = try - ignore (make (Ide, 4, 0)) ; + ignore (make Ide ~disk:4 ~partition:0) ; true with _ -> false in @@ -46,16 +46,18 @@ let equivalent = ; ("d536p37", "xvdtq37") ] +let invalid = ["d0p0q"] + let test_examples = let tests = List.map - (fun (spec, linux, xenstore) -> - ( "test_examples " ^ linux + (fun ((bus, disk, partition), linux, xenstore) -> + let of_spec = make bus ~disk ~partition |> Option.get in + let of_linux = of_linux_device linux |> Option.get in + let of_xenstore = of_xenstore_key xenstore in + ( Printf.sprintf "%s = %s = %d" (to_debug_string of_spec) linux xenstore , `Quick , fun () -> - let of_spec = make spec in - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in Alcotest.check device_number "examples must be equal" of_spec of_linux ; Alcotest.check device_number "examples must be equal" of_spec @@ -64,7 +66,7 @@ let test_examples = ) examples_to_test in - tests + ("Compare with linux and xenstore values", tests) (* NB we always understand the deprecated linux/xenstore devices even if we don't generate them ourselves *) @@ -72,40 +74,50 @@ let test_deprecated = let tests = List.map (fun (_, linux, xenstore) -> - ( "test_deprecated " ^ linux + ( linux , `Quick , fun () -> - let of_linux = of_linux_device linux in + let of_linux = of_linux_device linux |> Option.get in let of_xenstore = of_xenstore_key xenstore in Alcotest.check device_number "must be equal" of_linux of_xenstore ) ) deprecated in - tests + ("Deprecated linux device", tests) let test_equivalent = let tests = List.map (fun (x, y) -> - let test_name = Printf.sprintf "test_equivalent %s=%s" x y in + let test_name = Printf.sprintf "%s = %s" x y in ( test_name , `Quick , fun () -> - let x' = of_string false x in - let y' = of_string false y in + let x' = of_string ~hvm:false x |> Option.get in + let y' = of_string ~hvm:false y |> Option.get in Alcotest.check device_number "must be equal" x' y' ) ) equivalent in - tests + ("Equivalent devices", tests) + +let test_invalid = + let test x () = + if Option.is_some (of_string ~hvm:false x) then + Alcotest.failf "%s was not rejected" x + in + let tests = List.map (fun x -> (x, `Quick, test x)) invalid in + ("Reject invalid devices", tests) let test_2_way_convert = (* We now always convert Ide specs into xvd* linux devices, so they become Xen specs when converted back. *) - let equal_linux old_t new_t = - match (spec old_t, spec new_t) with + let equal_linux (old_t : t) (new_t : t) = + match + ((old_t, new_t) :> (bus_type * int * int) * (bus_type * int * int)) + with | (Ide, disk1, partition1), (Xen, disk2, partition2) when disk1 = disk2 && partition1 = partition2 -> true @@ -117,25 +129,36 @@ let test_2_way_convert = (Fmt.of_to_string Device_number.to_debug_string) equal_linux in + let test disk_number hvm = + let original = of_disk_number hvm disk_number |> Option.get in + let of_linux = of_linux_device (to_linux_device original) |> Option.get in + let of_xenstore = of_xenstore_key (to_xenstore_key original) in + Alcotest.check device_number_equal_linux + "of_linux must be equal to original" original of_linux ; + Alcotest.check device_number "of_xenstore must be equal to original" + original of_xenstore + in + + let max_d = (1 lsl 20) - 1 in + ( "2-way conversion" + , [ + ( Printf.sprintf "All disk numbers until %d" max_d + , `Slow + , fun () -> + for disk_number = 0 to max_d do + List.iter (test disk_number) [true; false] + done + ) + ] + ) + +let tests = [ - ( "test_2_way_convert" - , `Slow - , fun () -> - for disk_number = 0 to (1 lsl 20) - 1 do - List.iter - (fun hvm -> - let original = of_disk_number hvm disk_number in - let of_linux = of_linux_device (to_linux_device original) in - let of_xenstore = of_xenstore_key (to_xenstore_key original) in - Alcotest.check device_number_equal_linux - "of_linux must be equal to original" original of_linux ; - Alcotest.check device_number - "of_xenstore must be equal to original" original of_xenstore - ) - [true; false] - done - ) + test_examples + ; test_deprecated + ; test_equivalent + ; test_invalid + ; test_2_way_convert ] -let tests = - test_examples @ test_deprecated @ test_equivalent @ test_2_way_convert +let () = Alcotest.run "Device_number" tests diff --git a/ocaml/xapi-idl/lib_test/device_number_test.mli b/ocaml/xapi-idl/lib_test/device_number_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index 57c8c95e592..1b1e8193ca7 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -18,11 +18,22 @@ ) ) +(test + (name device_number_test) + (package xapi-idl) + (modules device_number_test) + (libraries + alcotest + fmt + xapi-idl.xen.interface.types + ) +) + (test (name test) (modes exe) (package xapi-idl) - (modules (:standard \ idl_test_common guard_interfaces_test)) + (modules (:standard \ idl_test_common guard_interfaces_test device_number_test)) (deps (source_tree test_data)) (libraries alcotest @@ -47,7 +58,6 @@ xapi-idl.v6 xapi-idl.xen xapi-idl.xen.interface - 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/lib_test/test.ml b/ocaml/xapi-idl/lib_test/test.ml index 712ac7a4640..bba5c5f6055 100644 --- a/ocaml/xapi-idl/lib_test/test.ml +++ b/ocaml/xapi-idl/lib_test/test.ml @@ -17,7 +17,6 @@ let () = ; ("Syslog tests", Syslog_test.tests) ; ("Cohttp_posix_io tests", Http_test.tests) ; ("Xenops_interface tests", Xen_test.tests) - ; ("Device_number tests", Device_number_test.tests) ; ("xcp-config-file tests", Config_file_test.tests) (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the code works. *) 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-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 2577c8a54ad..2233354b030 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -1,63 +1,48 @@ -type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] - -type spec = bus_type * int * int [@@deriving rpcty] +module Listext = Xapi_stdext_std.Listext.List -type t = spec [@@deriving rpcty] +type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] -let to_debug_string = function - | Xen, disk, partition -> - Printf.sprintf "Xen(%d, %d)" disk partition - | Scsi, disk, partition -> - Printf.sprintf "Scsi(%d, %d)" disk partition - | Floppy, disk, partition -> - Printf.sprintf "Floppy(%d, %d)" disk partition - | Ide, disk, partition -> - Printf.sprintf "Ide(%d, %d)" disk partition +type t = bus_type * int * int [@@deriving rpcty] -(* ocamlp4-friendly operators *) -let ( <| ) = ( lsl ) +let bus_type_to_string = function + | Xen -> + "Xen" + | Scsi -> + "Scsi" + | Floppy -> + "Floppy" + | Ide -> + "Ide" -let ( >| ) = ( lsr ) +let to_debug_string (bus, disk, partition) = + Printf.sprintf "%s(%d, %d)" (bus_type_to_string bus) disk partition -let int_of_string x = - try int_of_string x - with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) +let ( let* ) = Option.bind (* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) let use_deprecated_ide_encoding = true -let make (x : spec) : t = - let max_xen = ((1 <| 20) - 1, 15) in - let max_scsi = (15, 15) in - let max_ide = if use_deprecated_ide_encoding then (19, 63) else (3, 63) in - let max_floppy = (2, 0) in - let assert_in_range description (disk_limit, partition_limit) (disk, partition) - = - if disk < 0 || disk > disk_limit then - failwith - (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description - disk disk_limit - ) ; - if partition < 0 || partition > partition_limit then - failwith - (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" - description partition partition_limit - ) +let max_of = function + | Xen -> + ((1 lsl 20) - 1, 15) + | Scsi -> + (15, 15) + | Floppy -> + (2, 0) + | Ide -> + if use_deprecated_ide_encoding then (19, 63) else (3, 63) + +let make bus ~disk ~partition = + let in_range ~min ~max n = min <= n && n <= max in + let all_in_range (disk_max, partition_max) ~disk ~partition = + in_range ~min:0 ~max:disk_max disk + && in_range ~min:0 ~max:partition_max partition in - ( match x with - | Xen, disk, partition -> - assert_in_range "xen" max_xen (disk, partition) - | Scsi, disk, partition -> - assert_in_range "scsi" max_scsi (disk, partition) - | Floppy, disk, partition -> - assert_in_range "floppy" max_floppy (disk, partition) - | Ide, disk, partition -> - assert_in_range "ide" max_ide (disk, partition) - ) ; - x - -let spec (x : t) : spec = x + if all_in_range (max_of bus) ~disk ~partition then + Some (bus, disk, partition) + else + None let ( || ) = ( lor ) @@ -67,43 +52,41 @@ let deprecated_ide_table = standard_ide_table @ [33; 34; 56; 57; 88; 89; 90; 91] let to_xenstore_int = function | Xen, disk, partition when disk < 16 -> - 202 <| 8 || disk <| 4 || partition + (202 lsl 8) || (disk lsl 4) || partition | Xen, disk, partition -> - 1 <| 28 || disk <| 8 || partition + (1 lsl 28) || (disk lsl 8) || partition | Scsi, disk, partition -> - 8 <| 8 || disk <| 4 || partition + (8 lsl 8) || (disk lsl 4) || partition | Floppy, disk, partition -> - 203 <| 8 || disk <| 4 || partition + (203 lsl 8) || (disk lsl 4) || partition | Ide, disk, partition -> let m = List.nth deprecated_ide_table (disk / 2) in let n = disk - (disk / 2 * 2) in (* NB integers behave differently to reals *) - m <| 8 || n <| 6 || partition + (m lsl 8) || (n lsl 6) || partition let of_xenstore_int x = - let ( && ) = ( land ) in - if (x && 1 <| 28) <> 0 then - (Xen, x >| 8 && ((1 <| 20) - 1), x && ((1 <| 8) - 1)) + if x land (1 lsl 28) <> 0 then + (Xen, (x lsr 8) land ((1 lsl 20) - 1), x land ((1 lsl 8) - 1)) else - match x >| 8 with + match x lsr 8 with | 202 -> - (Xen, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Xen, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | 8 -> - (Scsi, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Scsi, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | 203 -> - (Floppy, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Floppy, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | n -> let idx = - snd - (List.fold_left - (fun (i, res) e -> (i + 1, if e = n then i else res)) - (0, -1) deprecated_ide_table - ) + match Listext.find_index (Int.equal n) deprecated_ide_table with + | Some idx -> + idx + | None -> + failwith (Printf.sprintf "Unknown device number: %d" x) in - if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; - (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) - -type xenstore_key = int + let disk = ((x lsr 6) land ((1 lsl 2) - 1)) + (idx * 2) in + let partition = x land ((1 lsl 6) - 1) in + (Ide, disk, partition) let to_xenstore_key x = to_xenstore_int x @@ -119,112 +102,119 @@ let rec string_of_int26 x = let low' = String.make 1 (char_of_int (low + int_of_char 'a' - 1)) in high' ^ low' -module String = struct - include String - - let fold_right f string accu = - let accu = ref accu in - for i = length string - 1 downto 0 do - accu := f string.[i] !accu - done ; - !accu - - let explode string = fold_right (fun h t -> h :: t) string [] - - let implode list = concat "" (List.map (String.make 1) list) -end - -(** Convert a linux device string back into an integer *) -let int26_of_string x = - let ints = - List.map (fun c -> int_of_char c - int_of_char 'a' + 1) (String.explode x) - in - List.fold_left (fun acc x -> (acc * 26) + x) 0 ints - 1 - -let to_linux_device = +let to_linux_prefix = function + | Xen -> + "xvd" + | Scsi -> + "sd" + | Floppy -> + "fd" + | Ide -> + "xvd" + +let to_linux_device (bus, disk, part) = let p x = if x = 0 then "" else string_of_int x in - function - | Xen, disk, part -> - Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) - | Scsi, disk, part -> - Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) - | Floppy, disk, part -> - Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) - | Ide, disk, part -> - Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) + let bus = to_linux_prefix bus in + Printf.sprintf "%s%s%s" bus (string_of_int26 disk) (p part) let of_linux_device x = - let letter c = 'a' <= c && c <= 'z' in - let digit c = '0' <= c && c <= '9' in - let take f x = - let rec inner f acc = function - | x :: xs -> - if f x then inner f (x :: acc) xs else (List.rev acc, x :: xs) - | [] -> - (List.rev acc, []) + let open Astring in + let b26_to_int x = + (* Convert a linux device string back into an integer *) + (* Assumes all characters are in range *) + let b26 = + String.Sub.to_string x + |> Stdlib.String.to_seq + |> Seq.map (fun c -> int_of_char c - int_of_char 'a' + 1) + |> Seq.fold_left (fun acc x -> (acc * 26) + x) 0 in - inner f [] x + b26 - 1 + in + + let parse_int x = + match String.Sub.span ~min:1 ~sat:Char.Ascii.is_digit x with + | i, s -> + Option.map (fun i -> (i, s)) (String.Sub.to_int i) + in + let parse_b26 x = + match String.Sub.span ~min:1 ~sat:Char.Ascii.is_lower x with + | b, s -> + (b26_to_int b, s) in (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 and y is 123 *) let parse_b26_int x = - let d, p = take letter x in - let d' = int26_of_string (String.implode d) in - let p' = if p = [] then 0 else int_of_string (String.implode p) in - (d', p') + let pre, x = parse_b26 x in + if String.Sub.is_empty x then + Some (pre, 0) + else + let* post, x = parse_int x in + if not (String.Sub.is_empty x) then + None + else + Some (pre, post) in (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) let parse_int_p_int x = - let d, rest = take digit x in - match rest with - | 'p' :: rest -> - let p, _ = take digit rest in - (int_of_string (String.implode d), int_of_string (String.implode p)) - | [] -> - (int_of_string (String.implode d), 0) - | _ -> - failwith - (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) + let parse_p x = + match String.Sub.head x with + | Some 'p' -> + Some (String.Sub.tail x) + | Some _ | None -> + None + in + let* pre, x = parse_int x in + if String.Sub.is_empty x then + Some (pre, 0) + else + let* x = parse_p x in + let* post, x = parse_int x in + if not (String.Sub.is_empty x) then + None + else + Some (pre, post) in - match String.explode x with - | 'x' :: 'v' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Xen, disk, partition) - | 's' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Scsi, disk, partition) - | 'f' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Floppy, disk, partition) - | 'h' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Ide, disk, partition) - | 'd' :: rest -> - let disk, partition = parse_int_p_int rest in - (Xen, disk, partition) - | _ -> - failwith (Printf.sprintf "Failed to parse device name: %s" x) + if String.is_prefix ~affix:"xvd" x then + let rest = String.sub_with_range ~first:3 x in + let* disk, partition = parse_b26_int rest in + Some (Xen, disk, partition) + else if String.is_prefix ~affix:"sd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Scsi, disk, partition) + else if String.is_prefix ~affix:"fd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Floppy, disk, partition) + else if String.is_prefix ~affix:"hd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Ide, disk, partition) + else if String.is_prefix ~affix:"d" x then + let rest = String.sub_with_range ~first:1 x in + let* disk, partition = parse_int_p_int rest in + Some (Xen, disk, partition) + else + None let upgrade_linux_device x = - match String.explode x with - | 'h' :: 'd' :: rest -> - "xvd" ^ String.implode rest - | _ -> - x - -type disk_number = int - -let to_disk_number = function - | Xen, disk, _ -> - disk - | Scsi, disk, _ -> - disk - | Floppy, disk, _ -> - disk - | Ide, disk, _ -> - disk - -let of_disk_number hvm n = if hvm && n < 4 then (Ide, n, 0) else (Xen, n, 0) - -let of_string hvm name = - try of_disk_number hvm (int_of_string name) with _ -> of_linux_device name + if Astring.String.is_prefix ~affix:"hd" x then + let rest = Astring.String.with_range ~first:2 x in + "xvd" ^ rest + else + x + +let disk (_, disk, _) = disk + +let bus (bus, _, _) = bus + +let of_disk_number hvm n = + let bus = if hvm && n < 4 then Ide else Xen in + make bus ~disk:n ~partition:0 + +let of_string ~hvm name = + let maybe_disk = + let* n = int_of_string_opt name in + of_disk_number hvm n + in + match maybe_disk with None -> of_linux_device name | dev -> dev diff --git a/ocaml/xapi-idl/xen/device_number.mli b/ocaml/xapi-idl/xen/device_number.mli index 4b5c431cd62..ffcfcbd05e9 100644 --- a/ocaml/xapi-idl/xen/device_number.mli +++ b/ocaml/xapi-idl/xen/device_number.mli @@ -5,23 +5,22 @@ type bus_type = | Floppy (** A floppy bus *) | Ide (** An IDE bus *) -(** A specification for a device number. There are more valid specifications - than valid device numbers because of hardware and/or protocol limits. *) -type spec = bus_type * int * int - (** A valid device number *) -type t +type t = private bus_type * int * int val typ_of : t Rpc.Types.typ -val make : spec -> t -(** [make spec] validates a given device number specification [spec] and returns - a device number *) +val make : bus_type -> disk:int -> partition:int -> t option +(** [make bus ~disk ~partition] returns [Some device] when the parameters + define a valid device number, or [None] otherwise. *) + +val disk : t -> int +(** [disk t] returns the corresponding non-negative disk number *) -val spec : t -> spec -(** [spec t] takes a [t] and returns the corresponding [spec] *) +val bus : t -> bus_type +(** [bus t] returns the bus type of the device *) -val of_string : bool -> string -> t +val of_string : hvm:bool -> string -> t option (** [of_string hvm name] returns the interface which best matches the [name] by applying the policy: first check if it is a disk_number, else fall back to a linux_device for backwards compatability *) @@ -33,26 +32,19 @@ val to_linux_device : t -> string (** [to_linux_device i] returns a possible linux string representation of interface [i] *) -val of_linux_device : string -> t +val of_linux_device : string -> t option (** [of_linux_device x] returns the interface corresponding to string [x] *) val upgrade_linux_device : string -> string (** [upgrade_linux_device x] upgrades hd* style device names to xvd* and leaves all other device names unchanged. *) -type xenstore_key = int - -val to_xenstore_key : t -> xenstore_key +val to_xenstore_key : t -> int (** [to_xenstore_key i] returns the xenstore key from interface [i] *) -val of_xenstore_key : xenstore_key -> t +val of_xenstore_key : int -> t (** [of_xenstore_key key] returns an interface from a xenstore key *) -type disk_number = int - -val to_disk_number : t -> disk_number -(** [to_disk_number i] returns the corresponding non-negative disk number *) - -val of_disk_number : bool -> disk_number -> t +val of_disk_number : bool -> int -> t option (** [of_disk_number hvm n] returns the interface corresponding to disk number [n] which depends on whether the guest is [hvm] or not. *) diff --git a/ocaml/xapi-idl/xen/dune b/ocaml/xapi-idl/xen/dune index c2352eff385..16ed23ecd22 100644 --- a/ocaml/xapi-idl/xen/dune +++ b/ocaml/xapi-idl/xen/dune @@ -3,6 +3,7 @@ (public_name xapi-idl.xen.interface.types) (modules xenops_types device_number) (libraries + astring result rpclib.core rresult @@ -10,6 +11,7 @@ sexplib0 threads xapi-idl + xapi-stdext-std ) (wrapped false) (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) 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/examples/volume/org.xen.xcp.storage.plainlvm/common.ml b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml index 298099be057..018c133c8dd 100644 --- a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml +++ b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml @@ -333,7 +333,7 @@ let vg_of_uri uri = let uri' = Uri.of_string uri in match Uri.scheme uri' with | Some "vg" -> - let vg = Uri.path uri' in + let vg = Uri.path_unencoded uri' in if vg <> "" && vg.[0] = '/' then String.sub vg 1 (String.length vg - 1) else diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 2c904af7a43..7420545205f 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -977,7 +977,7 @@ let bind ~volume_script_dir = let uri = Uri.of_string datasource in match Uri.scheme uri with | Some "xeno+shm" -> ( - let uid = Uri.path uri in + let uid = Uri.path_unencoded uri in let uid = if String.length uid > 1 then String.sub uid ~pos:1 ~len:(String.length uid - 1) @@ -1024,7 +1024,7 @@ let bind ~volume_script_dir = let uri = Uri.of_string datasource in match Uri.scheme uri with | Some "xeno+shm" -> ( - let uid = Uri.path uri in + let uid = Uri.path_unencoded uri in let uid = if String.length uid > 1 then String.sub uid ~pos:1 ~len:(String.length uid - 1) @@ -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/auth_signature.ml b/ocaml/xapi/auth_signature.ml index ff4fb076742..f4a16677712 100644 --- a/ocaml/xapi/auth_signature.ml +++ b/ocaml/xapi/auth_signature.ml @@ -67,12 +67,13 @@ type t = { the auth module/service itself -- e.g. maybe a SID or something in the AD case). Raises auth_failure if authentication is not successful *) - authenticate_username_password: string -> string -> string + authenticate_username_password: + __context:Context.t -> string -> string -> string ; (* subject_id Authenticate_ticket(string ticket) As above but uses a ticket as credentials (i.e. for single sign-on) *) - authenticate_ticket: string -> string + authenticate_ticket: __context:Context.t -> string -> string ; (* subject_id get_subject_identifier(string subject_name) Takes a subject_name (as may be entered into the XenCenter UI when defining subjects -- @@ -80,7 +81,7 @@ type t = { auth/directory service. Raises Not_found if authentication is not succesful. *) - get_subject_identifier: string -> string + get_subject_identifier: __context:Context.t -> string -> string ; (* ((string*string) list) query_subject_information(string subject_identifier) Takes a subject_identifier and returns the user record from the directory service as @@ -91,7 +92,8 @@ type t = { it's a string*string list anyway for possible future expansion. Raises Not_found if subject_id cannot be resolved by external auth service *) - query_subject_information: string -> (string * string) list + query_subject_information: + __context:Context.t -> string -> (string * string) list ; (* (string list) query_group_membership(string subject_identifier) Takes a subject_identifier and returns its group membership (i.e. a list of subject @@ -99,7 +101,7 @@ type t = { _must_ be transitively closed wrt the is_member_of relation if the external directory service supports nested groups (as AD does for example) *) - query_group_membership: string -> string list + query_group_membership: __context:Context.t -> string -> string list ; (* In addition, there are some event hooks that auth modules implement as follows: *) @@ -118,7 +120,7 @@ type t = { explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - on_enable: (string * string) list -> unit + on_enable: __context:Context.t -> (string * string) list -> unit ; (* unit on_disable() Called internally by xapi _on each host_ when a client disables an auth service via the XenAPI. @@ -126,18 +128,18 @@ type t = { service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - on_disable: (string * string) list -> unit + on_disable: __context:Context.t -> (string * string) list -> unit ; (* unit on_xapi_initialize(bool system_boot) Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - on_xapi_initialize: bool -> unit + on_xapi_initialize: __context:Context.t -> bool -> unit ; (* unit on_xapi_exit() Called internally when xapi is doing a clean exit. *) - on_xapi_exit: unit -> unit + on_xapi_exit: __context:Context.t -> unit -> unit } (* Auth modules must implement this signature:*) diff --git a/ocaml/xapi/authx.ml b/ocaml/xapi/authx.ml index 73224d31295..87d85e40332 100644 --- a/ocaml/xapi/authx.ml +++ b/ocaml/xapi/authx.ml @@ -19,6 +19,8 @@ module D = Debug.Make (struct let name = "extauth_plugin_PAM_NSS" end) open D +let ( let@ ) = ( @@ ) + module AuthX : Auth_signature.AUTH_MODULE = struct (* * External Authentication Plugin component @@ -113,7 +115,8 @@ module AuthX : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found if authentication is not succesful. *) - let get_subject_identifier subject_name = + let get_subject_identifier ~__context subject_name = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in try (* looks up list of users*) "u" ^ getent_idbyname "passwd" subject_name with Not_found -> @@ -131,7 +134,8 @@ module AuthX : Auth_signature.AUTH_MODULE = struct Raises auth_failure if authentication is not successful *) - let authenticate_username_password username password = + let authenticate_username_password ~__context username password = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* we try to authenticate against our user database using PAM *) let () = try @@ -139,7 +143,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct (* no exception raised, then authentication succeeded *) with Failure msg -> raise (Auth_signature.Auth_failure msg) in - try get_subject_identifier username + try get_subject_identifier ~__context username with Not_found -> raise (Auth_signature.Auth_failure @@ -155,7 +159,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct *) (* not implemented now, not needed for our tests, only for a *) (* future single sign-on feature *) - let authenticate_ticket _tgt = + let authenticate_ticket ~__context:_ _tgt = failwith "authx authenticate_ticket not implemented" (* ((string*string) list) query_subject_information(string subject_identifier) @@ -168,7 +172,8 @@ module AuthX : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found if subject_id cannot be resolved by external auth service *) - let query_subject_information subject_identifier = + let query_subject_information ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* we are expecting an id such as u0, g0, u123 etc *) if String.length subject_identifier < 2 then raise Not_found ; match subject_identifier.[0] with @@ -246,7 +251,8 @@ module AuthX : Auth_signature.AUTH_MODULE = struct *) (* in unix, groups cannot contain groups, so we just verify the groups a user *) (* belongs to and, if that fails, if some group has the required identifier *) - let query_group_membership subject_identifier = + let query_group_membership ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* 1. first we try to see if our subject identifier is a user id...*) let sanitized_subject_id = String.escaped subject_identifier in (* we are expecting an id such as u0, g0, u123 etc *) @@ -303,7 +309,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable _config_params = + let on_enable ~__context:_ _config_params = (* nothing to do in this unix plugin, we always have /etc/passwd and /etc/group *) () @@ -314,7 +320,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable _config_params = + let on_disable ~__context:_ _config_params = (* nothing to disable in this unix plugin, we should not disable /etc/passwd and /etc/group:) *) () @@ -323,7 +329,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize _system_boot = + let on_xapi_initialize ~__context:_ _system_boot = (* again, nothing to be initialized here in this unix plugin *) () @@ -331,21 +337,22 @@ module AuthX : Auth_signature.AUTH_MODULE = struct Called internally when xapi is doing a clean exit. *) - let on_xapi_exit () = + let on_xapi_exit ~__context:_ () = (* nothing to do here in this unix plugin *) () (* Implement the single value required for the module signature *) let methods = - { - Auth_signature.authenticate_username_password - ; Auth_signature.authenticate_ticket - ; Auth_signature.get_subject_identifier - ; Auth_signature.query_subject_information - ; Auth_signature.query_group_membership - ; Auth_signature.on_enable - ; Auth_signature.on_disable - ; Auth_signature.on_xapi_initialize - ; Auth_signature.on_xapi_exit - } + Auth_signature. + { + authenticate_username_password + ; authenticate_ticket + ; get_subject_identifier + ; query_subject_information + ; query_group_membership + ; on_enable + ; on_disable + ; on_xapi_initialize + ; on_xapi_exit + } end 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/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 84af29bbf7f..32ee7d44d21 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -69,7 +69,7 @@ let get_start_time () = debug "Calculating boot time..." ; let now = Unix.time () in let uptime = Unixext.string_of_file "/proc/uptime" in - let uptime = String.strip String.isspace uptime in + let uptime = String.trim uptime in let uptime = String.split ' ' uptime in let uptime = List.hd uptime in let uptime = float_of_string uptime in 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/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index dd14ab6df4c..fc73c7b7cb6 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -20,6 +20,8 @@ module D = Debug.Make (struct let name = "extauth_plugin_ADpbis" end) open D open Xapi_stdext_std.Xstringext +let ( let@ ) = ( @@ ) + let finally = Xapi_stdext_pervasives.Pervasiveext.finally let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute @@ -584,7 +586,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) - let get_subject_identifier _subject_name = + let get_subject_identifier ~__context _subject_name = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + try (* looks up list of users*) let subject_name = get_full_subject_name _subject_name in @@ -610,7 +614,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Raises auth_failure if authentication is not successful *) - let authenticate_username_password username password = + let authenticate_username_password ~__context username password = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* first, we try to authenticated user against our external user database *) (* pbis_common will raise an Auth_failure if external authentication fails *) let domain, user = @@ -639,7 +644,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in (* no exception raised, then authentication succeeded, *) (* now we return the authenticated user's id *) - get_subject_identifier (get_full_subject_name username) + get_subject_identifier ~__context (get_full_subject_name username) (* subject_id Authenticate_ticket(string ticket) @@ -647,7 +652,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct *) (* not implemented now, not needed for our tests, only for a *) (* future single sign-on feature *) - let authenticate_ticket _tgt = + let authenticate_ticket ~__context:_ _tgt = failwith "extauth_plugin authenticate_ticket not implemented" (* ((string*string) list) query_subject_information(string subject_identifier) @@ -660,7 +665,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found (*Subject_cannot_be_resolved*) if subject_id cannot be resolved by external auth service *) - let query_subject_information subject_identifier = + let query_subject_information ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let unmap_lw_space_chars lwname = let defensive_copy = Bytes.of_string lwname in (* CA-29006: map chars in names back to original space chars in windows-names *) @@ -729,8 +735,12 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct _must_ be transitively closed wrt the is_member_of relation if the external directory service supports nested groups (as AD does for example) *) - let query_group_membership subject_identifier = - let subject_info = query_subject_information subject_identifier in + let query_group_membership ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + + let subject_info = + query_subject_information ~__context subject_identifier + in if List.assoc "subject-is-group" subject_info = "true" (* this field is always present *) @@ -759,7 +769,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct In addition, there are some event hooks that auth modules implement as follows: *) - let _is_pbis_server_available max_tries = + let _is_pbis_server_available ~__context max_tries = (* we _need_ to use a username contained in our domain, otherwise the following tests won't work. Microsoft KB/Q243330 article provides the KRBTGT account as a well-known built-in SID in AD Microsoft KB/Q229909 article says that KRBTGT account cannot be renamed or enabled, making @@ -793,12 +803,14 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in let try_fetch_sid () = try - let sid = get_subject_identifier krbtgt in + let sid = get_subject_identifier ~__context krbtgt in debug "Request to external authentication server successful: user %s was \ found" krbtgt ; - let (_ : (string * string) list) = query_subject_information sid in + let (_ : (string * string) list) = + query_subject_information ~__context sid + in debug "Request to external authentication server successful: sid %s was \ found" @@ -849,9 +861,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in go 0 - let is_pbis_server_available max = + let is_pbis_server_available ~__context max = Locking_helpers.Named_mutex.execute mutex_check_availability (fun () -> - _is_pbis_server_available max + _is_pbis_server_available ~__context max ) (* converts from domain.com\user to user@domain.com, in case domain.com is present in the subject_name *) @@ -885,7 +897,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable config_params = + let on_enable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* but in the ldap plugin, we should 'join the AD/kerberos domain', i.e. we should*) (* basically: (1) create a machine account in the kerberos realm,*) (* (2) store the machine account password somewhere locally (in a keytab) *) @@ -990,7 +1003,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in let max_tries = 60 in (* tests 60 x 5.0 seconds = 300 seconds = 5minutes trying *) - if not (is_pbis_server_available max_tries) then ( + if not (is_pbis_server_available ~__context max_tries) then ( let errmsg = Printf.sprintf "External authentication server not available after %i query \ @@ -1033,7 +1046,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable config_params = + let on_disable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* but in the ldap plugin, we should 'leave the AD/kerberos domain', i.e. we should *) (* (1) remove the machine account from the kerberos realm, (2) remove the keytab locally *) let pbis_failure = @@ -1130,7 +1144,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize _system_boot = + let on_xapi_initialize ~__context _system_boot = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + (* the AD server is initialized outside xapi, by init.d scripts *) (* this function is called during xapi initialization in xapi.ml *) @@ -1138,7 +1154,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct (* make sure that the AD/LSASS server is responding before returning *) let max_tries = 12 in (* tests 12 x 5.0 seconds = 60 seconds = up to 1 minute trying *) - if not (is_pbis_server_available max_tries) then ( + if not (is_pbis_server_available ~__context max_tries) then ( let errmsg = Printf.sprintf "External authentication server not available after %i query tests" @@ -1154,7 +1170,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Called internally when xapi is doing a clean exit. *) - let on_xapi_exit () = + let on_xapi_exit ~__context:_ () = (* nothing to do here in this unix plugin *) (* in the ldap plugin, we should remove the tgt ticket in /tmp/krb5cc_0 *) @@ -1162,15 +1178,16 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct (* Implement the single value required for the module signature *) let methods = - { - Auth_signature.authenticate_username_password - ; Auth_signature.authenticate_ticket - ; Auth_signature.get_subject_identifier - ; Auth_signature.query_subject_information - ; Auth_signature.query_group_membership - ; Auth_signature.on_enable - ; Auth_signature.on_disable - ; Auth_signature.on_xapi_initialize - ; Auth_signature.on_xapi_exit - } + Auth_signature. + { + authenticate_username_password + ; authenticate_ticket + ; get_subject_identifier + ; query_subject_information + ; query_group_membership + ; on_enable + ; on_disable + ; on_xapi_initialize + ; on_xapi_exit + } end diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index bcfbd31e8e8..fc0aa01ad0b 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -29,6 +29,8 @@ let krbtgt = "KRBTGT" let ( let* ) = Result.bind +let ( let@ ) = ( @@ ) + let ( ) x f = Rresult.R.reword_error f x let ( >>| ) = Rresult.( >>| ) @@ -1361,7 +1363,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) - let get_subject_identifier subject_name = + let get_subject_identifier ~__context subject_name = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in maybe_raise (get_subject_identifier' subject_name) (* subject_id Authenticate_username_password(string username, string password) @@ -1375,7 +1378,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Raises auth_failure if authentication is not successful *) - let authenticate_username_password uname password = + let authenticate_username_password ~__context uname password = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* the `wbinfo --krb5auth` expects the username to be in either SAM or UPN format. * we use wbinfo to try to convert the provided [uname] into said format. * as a last ditch attempt, we try to auth with the provided [uname] @@ -1415,7 +1419,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct *) (* not implemented now, not needed for our tests, only for a *) (* future single sign-on feature *) - let authenticate_ticket _tgt = + let authenticate_ticket ~__context:_ _tgt = failwith "extauth_plugin authenticate_ticket not implemented" let query_subject_information_group (name : string) (gid : int) (sid : string) @@ -1512,7 +1516,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found (*Subject_cannot_be_resolved*) if subject_id cannot be resolved by external auth service *) - let query_subject_information (sid : string) = + let query_subject_information ~__context (sid : string) = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let res = let* name = Wbinfo.name_of_sid sid in match name with @@ -1534,7 +1539,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct _must_ be transitively closed wrt the is_member_of relation if the external directory service supports nested groups (as AD does for example) *) - let query_group_membership subject_identifier = + let query_group_membership ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in maybe_raise (Wbinfo.user_domgroups subject_identifier) let assert_join_domain_user_format uname = @@ -1560,7 +1566,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable config_params = + let on_enable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let user = from_config ~name:"user" ~err_msg:"enable requires user" ~config_params in @@ -1654,7 +1661,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable config_params = + let on_disable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let user = List.assoc_opt "user" config_params in let pass = List.assoc_opt "pass" config_params in let {service_name; _} = get_domain_info_from_db () in @@ -1676,7 +1684,9 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize _system_boot = + let on_xapi_initialize ~__context _system_boot = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Winbind.start ~timeout:5. ~wait_until_success:true ; ClosestKdc.trigger_update ~start:ClosestKdc.startup_delay ; RotateMachinePassword.trigger_rotate ~start:5. ; @@ -1686,19 +1696,20 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Called internally when xapi is doing a clean exit. *) - let on_xapi_exit () = () + let on_xapi_exit ~__context:_ () = () (* Implement the single value required for the module signature *) let methods = - { - Auth_signature.authenticate_username_password - ; Auth_signature.authenticate_ticket - ; Auth_signature.get_subject_identifier - ; Auth_signature.query_subject_information - ; Auth_signature.query_group_membership - ; Auth_signature.on_enable - ; Auth_signature.on_disable - ; Auth_signature.on_xapi_initialize - ; Auth_signature.on_xapi_exit - } + Auth_signature. + { + authenticate_username_password + ; authenticate_ticket + ; get_subject_identifier + ; query_subject_information + ; query_group_membership + ; on_enable + ; on_disable + ; on_xapi_initialize + ; on_xapi_exit + } end 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/storage_access.ml b/ocaml/xapi/storage_access.ml index 02e5545d16e..a307eb48bdd 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -558,8 +558,17 @@ let of_vbd ~__context ~vbd ~domid = Helpers.has_qemu ~__context ~self:(Db.VBD.get_VM ~__context ~self:vbd) in let dbg = Context.get_task_id __context in - let device_number = Device_number.of_string has_qemu userdevice in - let device = Device_number.to_linux_device device_number in + let device = + Option.map Device_number.to_linux_device + (Device_number.of_string ~hvm:has_qemu userdevice) + in + let device = + match device with + | Some dev -> + dev + | None -> + raise Api_errors.(Server_error (invalid_device, [userdevice])) + in let dp = datapath_of_vbd ~domid ~device in ( rpc , Ref.string_of dbg 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/vbdops.ml b/ocaml/xapi/vbdops.ml index 18e1f8413b9..0b9494e6f9e 100644 --- a/ocaml/xapi/vbdops.ml +++ b/ocaml/xapi/vbdops.ml @@ -24,15 +24,15 @@ module L = Debug.Make (struct let name = "license" end) (** Thrown if an empty VBD which isn't a CDROM is attached to an HVM guest *) exception Only_CD_VBDs_may_be_empty -let translate_vbd_device vbd_ref name is_hvm = - try - let i = Device_number.of_string is_hvm name in - debug "VBD device name %s interpreted as %s (hvm = %b)" name - (Device_number.to_debug_string i) - is_hvm ; - i - with _ -> - raise - (Api_errors.Server_error - (Api_errors.illegal_vbd_device, [Ref.string_of vbd_ref; name]) - ) +let translate_vbd_device vbd_ref name hvm = + match Device_number.of_string ~hvm name with + | Some i -> + debug "VBD device name %s interpreted as %s (hvm = %b)" name + (Device_number.to_debug_string i) + hvm ; + i + | None -> + raise + (Api_errors.Server_error + (Api_errors.illegal_vbd_device, [Ref.string_of vbd_ref; name]) + ) 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..f06c19720f5 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 @@ -1053,7 +1024,8 @@ let server_init () = while not !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded do try (* try to initialize external authentication service *) - (Ext_auth.d ()).on_xapi_initialize !Xapi_globs.on_system_boot ; + (Ext_auth.d ()).on_xapi_initialize ~__context + !Xapi_globs.on_system_boot ; (* tell everybody the service initialized successfully *) Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded := true ; (* 3. Now that we are sure that the external authentication service is working,*) diff --git a/ocaml/xapi/xapi_auth.ml b/ocaml/xapi/xapi_auth.ml index 58a851b3052..60ac443edd4 100644 --- a/ocaml/xapi/xapi_auth.ml +++ b/ocaml/xapi/xapi_auth.ml @@ -39,15 +39,15 @@ let call_with_exception_handler fn = let get_subject_identifier ~__context ~subject_name = call_with_exception_handler (fun () -> - (Ext_auth.d ()).get_subject_identifier subject_name + (Ext_auth.d ()).get_subject_identifier ~__context subject_name ) let get_group_membership ~__context ~subject_identifier = call_with_exception_handler (fun () -> - (Ext_auth.d ()).query_group_membership subject_identifier + (Ext_auth.d ()).query_group_membership ~__context subject_identifier ) let get_subject_information_from_identifier ~__context ~subject_identifier = call_with_exception_handler (fun () -> - (Ext_auth.d ()).query_subject_information subject_identifier + (Ext_auth.d ()).query_subject_information ~__context subject_identifier ) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 93a65dadd12..545674e92e0 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -427,11 +427,16 @@ let compute_corosync_max_host_failures ~__context = corosync_ha_max_hosts module Watcher = struct + let routine_updates = "routine updates" + let on_corosync_update ~__context ~cluster updates = - debug - "%s: Received %d updates from corosync_notifyd, run diagnostics to get \ - new state" - __FUNCTION__ (List.length updates) ; + if updates = [routine_updates] then + debug "%s: Perform routine updates" __FUNCTION__ + else + debug + "%s: Received %d updates from corosync_notifyd, run diagnostics to get \ + new state" + __FUNCTION__ (List.length updates) ; let m = Cluster_client.LocalClient.diagnostics (rpc ~__context) "update quorum api fields with diagnostics" @@ -535,10 +540,10 @@ module Watcher = struct let cluster_change_watcher : bool Atomic.t = Atomic.make false - (* this is the time it takes for the update request to time out. It is ok to set + (* This is the time it takes for the update request to time out. It is ok to set it to a relatively long value since the call will return immediately if there - is an update *) - let cluster_change_interval = Mtime.Span.min + is an update. *) + let cluster_change_interval = Mtime.Span.(5 * min) let cluster_stack_watcher : bool Atomic.t = Atomic.make false @@ -550,21 +555,27 @@ module Watcher = struct while !Daemon.enabled do let m = Cluster_client.LocalClient.UPDATES.get (rpc ~__context) - "call cluster watcher" + "cluster change watcher call" (Clock.Timer.span_to_s cluster_change_interval) in - match Idl.IdM.run @@ Cluster_client.IDL.T.get m with - | Ok updates -> ( + let find_cluster_and_update updates = match find_cluster_host ~__context ~host with | Some ch -> let cluster = Db.Cluster_host.get_cluster ~__context ~self:ch in on_corosync_update ~__context ~cluster updates | None -> () - ) + in + match Idl.IdM.run @@ Cluster_client.IDL.T.get m with + | Ok updates -> + (* Received updates from corosync-notifyd *) + find_cluster_and_update updates | Error (InternalError "UPDATES.Timeout") -> - (* UPDATES.get timed out, this is normal, now retry *) - () + (* UPDATES.get timed out, this is normal. *) + (* CA-395789: We send a query to xapi-clusterd to fetch the latest state + anyway in case there is a race and the previous update did not give the + most up-to-date information *) + find_cluster_and_update [routine_updates] | Error (InternalError message) | Error (Unix_error message) -> warn "%s: Cannot query cluster host updates with error %s" __FUNCTION__ message diff --git a/ocaml/xapi/xapi_dr_task.ml b/ocaml/xapi/xapi_dr_task.ml index 631c7ee4916..415a4e45c8f 100644 --- a/ocaml/xapi/xapi_dr_task.ml +++ b/ocaml/xapi/xapi_dr_task.ml @@ -26,17 +26,12 @@ 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 | Xml.Element (key, _, [Xml.PCData v]) -> - (key, String.strip String.isspace v) (* remove whitespace at both ends *) + (key, String.trim v) | Xml.Element (key, _, []) -> (key, "") | _ -> @@ -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_host.ml b/ocaml/xapi/xapi_host.ml index 666c5500bf4..05955958813 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1778,7 +1778,7 @@ let enable_external_auth ~__context ~host ~config ~service_name ~auth_type = (* use the special 'named dispatcher' function to call an extauth plugin function even though we have *) (* not yet set up the external_auth_type value that will enable generic access to the extauth plugin. *) - (Ext_auth.nd auth_type).on_enable config ; + (Ext_auth.nd auth_type).on_enable ~__context config ; (* from this point on, we have successfully enabled the external authentication services. *) @@ -1891,7 +1891,7 @@ let disable_external_auth_common ?(during_pool_eject = false) ~__context ~host (* 1. first, we try to call the external auth plugin to disable the external authentication service *) let plugin_disable_failure = try - (Ext_auth.d ()).on_disable config ; + (Ext_auth.d ()).on_disable ~__context config ; None (* OK, on_disable succeeded *) with | Auth_signature.Auth_service_error (errtag, msg) -> 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..63598c0d6b4 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 @@ -2559,7 +2559,8 @@ let revalidate_subjects ~__context = debug "Revalidating subject %s" subj_id ; try let open Auth_signature in - ignore ((Extauth.Ext_auth.d ()).query_subject_information subj_id) + ignore + ((Extauth.Ext_auth.d ()).query_subject_information ~__context subj_id) with Not_found -> debug "Destroying subject %s" subj_id ; Xapi_subject.destroy ~__context ~self diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 1417b4d8313..9567dd156a2 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 = +let do_external_auth ~__context 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 ~__context 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) @@ -502,7 +487,8 @@ let revalidate_external_session ~__context ~session = try (* if the user is not in the external directory service anymore, this call raises Not_found *) let group_membership_closure = - (Ext_auth.d ()).query_group_membership authenticated_user_sid + (Ext_auth.d ()).query_group_membership ~__context + authenticated_user_sid in debug "obtained group membership for session %s, sid %s " (trackid session) authenticated_user_sid ; @@ -725,22 +711,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 +740,399 @@ 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 ~__context 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 ~__context + 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 - if subject_suspended then ( + 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 ( 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 +1144,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_subject.ml b/ocaml/xapi/xapi_subject.ml index 5c1cdd69a5d..fcdc8710dc4 100644 --- a/ocaml/xapi/xapi_subject.ml +++ b/ocaml/xapi/xapi_subject.ml @@ -261,4 +261,4 @@ let get_subject_information_from_identifier ~__context ~cache identifier = if cache then query_subject_information_from_db ~__context identifier else - (Ext_auth.d ()).query_subject_information identifier + (Ext_auth.d ()).query_subject_information ~__context identifier diff --git a/ocaml/xapi/xapi_templates_install.ml b/ocaml/xapi/xapi_templates_install.ml index c22e51bf0ae..fc126b588bb 100644 --- a/ocaml/xapi/xapi_templates_install.ml +++ b/ocaml/xapi/xapi_templates_install.ml @@ -34,10 +34,7 @@ let is_whitelisted script = | _ -> false in - let safe_str str = - List.fold_left ( && ) true - (List.map safe_char (Xapi_stdext_std.Xstringext.String.explode str)) - in + let safe_str str = String.for_all safe_char str in (* make sure the script prefix is the allowed dom0 directory *) Filename.dirname script = !Xapi_globs.post_install_scripts_dir (* avoid ..-style attacks and other weird things *) diff --git a/ocaml/xapi/xapi_vbd.ml b/ocaml/xapi/xapi_vbd.ml index 1da2516d809..5e1b31c5bee 100644 --- a/ocaml/xapi/xapi_vbd.ml +++ b/ocaml/xapi/xapi_vbd.ml @@ -215,24 +215,23 @@ let create ~__context ~vM ~vDI ~device ~userdevice ~bootable ~mode ~_type ) ) in - if - (not (valid_device userdevice ~_type)) - || (userdevice = "autodetect" && possibilities = []) - then - raise - (Api_errors.Server_error (Api_errors.invalid_device, [userdevice])) ; + let raise_invalid_device () = + raise Api_errors.(Server_error (invalid_device, [userdevice])) + in + if not (valid_device userdevice ~_type) then + raise_invalid_device () ; (* Resolve the "autodetect" into a fixed device name now *) let userdevice = - if userdevice = "autodetect" then - match _type with - (* already checked for [] above *) - | `Floppy -> - Device_number.to_linux_device (List.hd possibilities) - | `CD | `Disk -> - string_of_int - (Device_number.to_disk_number (List.hd possibilities)) - else + if userdevice <> "autodetect" then userdevice + else + match (_type, possibilities) with + | _, [] -> + raise_invalid_device () + | `Floppy, dev :: _ -> + Device_number.to_linux_device dev + | (`CD | `Disk), dev :: _ -> + string_of_int (Device_number.disk dev) in let uuid = Uuidx.make () in let ref = Ref.make () in diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 6226b26c34e..1285c740c27 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -376,38 +376,17 @@ let clear_current_operations ~__context ~self = (** Check if the device string has the right form *) let valid_device dev ~_type = - let check_rest rest = - (* checks the rest of the device name = [] is ok, or a number is ok *) - if rest = [] then - true - else - try - ignore (int_of_string (String.implode rest)) ; - true - with _ -> false - in dev = "autodetect" + || Option.is_none (Device_number.of_string dev ~hvm:false) || - match String.explode dev with - | 's' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'x' :: 'v' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'h' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'f' :: 'd' :: 'a' .. 'b' :: rest -> - check_rest rest - (* QEMU only supports up to 2 floppy drives, hence fda or fdb *) + match _type with + | `Floppy -> + false | _ -> ( - match _type with - | `Floppy -> - false - | _ -> ( - try - let n = int_of_string dev in - n >= 0 || n < 16 - with _ -> false - ) + try + let n = int_of_string dev in + n >= 0 || n < 16 + with _ -> false ) (** VBD.destroy doesn't require any interaction with xen *) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8819d393170..eff46f84b93 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1206,7 +1206,7 @@ let get_possible_hosts ~__context ~vm = let get_allowed_VBD_devices ~__context ~vm = List.map - (fun d -> string_of_int (Device_number.to_disk_number d)) + (fun d -> string_of_int (Device_number.disk d)) (snd @@ allowed_VBD_devices ~__context ~vm ~_type:`Disk) let get_allowed_VIF_devices = allowed_VIF_devices diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index c715303b836..88590dc195b 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -1284,7 +1284,7 @@ let set_HVM_shadow_multiplier ~__context ~self ~value = let inclusive_range a b = List.init (b - a + 1) (fun k -> a + k) let vbd_inclusive_range hvm a b = - List.map (Device_number.of_disk_number hvm) (inclusive_range a b) + List.filter_map (Device_number.of_disk_number hvm) (inclusive_range a b) let vif_inclusive_range a b = List.map string_of_int (inclusive_range a b) @@ -1302,8 +1302,8 @@ let allowed_VBD_devices_PV = vbd_inclusive_range false 0 254 let allowed_VBD_devices_control_domain = vbd_inclusive_range false 0 255 let allowed_VBD_devices_HVM_floppy = - List.map - (fun x -> Device_number.make (Device_number.Floppy, x, 0)) + List.filter_map + (fun x -> Device_number.(make Floppy ~disk:x ~partition:0)) (inclusive_range 0 1) let allowed_VIF_devices_HVM = vif_inclusive_range 0 6 @@ -1314,8 +1314,8 @@ let allowed_VIF_devices_PV = vif_inclusive_range 0 6 represent possible interpretations of [s]. *) let possible_VBD_devices_of_string s = (* NB userdevice fields are arbitrary strings and device fields may be "" *) - let parse hvm x = try Some (Device_number.of_string hvm x) with _ -> None in - Listext.List.unbox_list [parse true s; parse false s] + let parse hvm x = Device_number.of_string ~hvm x in + List.filter_map Fun.id [parse true s; parse false s] (** [all_used_VBD_devices __context self] returns a list of Device_number.t which are considered to be already in-use in the VM *) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 50aa2c6c53d..dfb2b666205 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) @@ -560,31 +555,37 @@ module MD = struct | `pv_in_pvh | `pv | `pvh | `unspecified -> false in - let device_number = Device_number.of_string hvm vbd.API.vBD_userdevice in + let device_number = + match Device_number.of_string ~hvm vbd.API.vBD_userdevice with + | Some dev -> + dev + | None -> + raise + Api_errors.(Server_error (invalid_device, [vbd.API.vBD_userdevice])) + in let open Vbd in let ty = vbd.API.vBD_qos_algorithm_type in let params = vbd.API.vBD_qos_algorithm_params in let qos_class params = - if List.mem_assoc "class" params then - match List.assoc "class" params with - | "highest" -> - Highest - | "high" -> - High - | "normal" -> - Normal - | "low" -> - Low - | "lowest" -> - Lowest - | s -> ( - try Other (int_of_string s) - with _ -> - warn "Unknown VBD QoS scheduler class (try 'high' 'low' 'normal')" ; - Normal - ) - else - Normal + match List.assoc_opt "class" params with + | Some "highest" -> + Highest + | Some "high" -> + High + | Some "normal" -> + Normal + | Some "low" -> + Low + | Some "lowest" -> + Lowest + | Some s -> ( + try Other (int_of_string s) + with _ -> + warn "Unknown VBD QoS scheduler class (try 'high' 'low' 'normal')" ; + Normal + ) + | None -> + Normal in let qos_scheduler params = try @@ -2464,18 +2465,16 @@ let update_vbd ~__context (id : string * string) = in let linux_device = snd id in let device_number = Device_number.of_linux_device linux_device in - (* only try matching against disk number if the device is not a floppy (as "0" shouldn't match "fda") *) - let disk_number = - match Device_number.spec device_number with - | Device_number.Ide, _, _ | Device_number.Xen, _, _ -> - Some - (device_number - |> Device_number.to_disk_number - |> string_of_int - ) + let disk_of dev = + (* only try matching against disk number if the device is not a + floppy (as "0" shouldn't match "fda") *) + match Device_number.bus dev with + | Ide | Xen -> + Some (string_of_int Device_number.(disk dev)) | _ -> None in + let disk_number = Option.bind device_number disk_of in debug "VM %s VBD userdevices = [ %s ]" (fst id) (String.concat "; " (List.map (fun (_, r) -> r.API.vBD_userdevice) vbdrs) diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 608ae9a64a2..53be303e04c 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -40,9 +40,9 @@ let first_xml_element_with_name elements name = are stripped of leading and trailing whitespace. *) let hash_table_entry_of_leaf_xml_element = function | Xml.Element (name, _, Xml.PCData value :: _) -> - Some (String.strip String.isspace name, String.strip String.isspace value) + Some (String.trim name, String.trim value) | Xml.Element (name, _, []) -> - Some (String.strip String.isspace name, "") + Some (String.trim name, "") | _ -> None diff --git a/ocaml/xapi/xmlrpc_sexpr.ml b/ocaml/xapi/xmlrpc_sexpr.ml index 4e394fdb697..d241491cdc3 100644 --- a/ocaml/xapi/xmlrpc_sexpr.ml +++ b/ocaml/xapi/xmlrpc_sexpr.ml @@ -41,7 +41,7 @@ let xmlrpc_to_sexpr (root : xml) = | _, [] -> [] | _, PCData text :: _ -> - let text = String.strip String.isspace text in + let text = String.trim text in [SExpr.String text] (* empty s have default value '' *) | h, Element ("value", _, []) :: siblings -> @@ -69,7 +69,7 @@ let xmlrpc_to_sexpr (root : xml) = (*ignore incorrect member*) (* any other element *) | h, Element (tag, _, children) :: siblings -> - let tag = String.strip String.isspace tag in + let tag = String.trim tag in let mytag = SExpr.String tag in let (mychildren : SExpr.t list) = visit (h + 1) children in let anode = SExpr.Node (mytag :: mychildren) in 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/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 9be987f028b..520d43e0061 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -135,7 +135,7 @@ let parse_url url = let ( let* ) = Option.bind in let* scheme = Uri.scheme uri in let* host = Uri.host uri in - let path = Uri.path_and_query uri in + let path = Uri.path_and_query uri |> Uri.pct_decode in Some (scheme, host, path) in match parse (Uri.of_string url) with 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/xen_api_lwt_unix.ml b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml index 863f32f0829..a69e9423087 100644 --- a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml +++ b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml @@ -66,7 +66,7 @@ module Lwt_unix_IO = struct let open_connection uri = ( match Uri.scheme uri with | Some "file" -> - return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.path uri), false) + return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.path_unencoded uri), false) | Some "http+unix" -> return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.host_with_default uri), false) | Some "http" | Some "https" -> 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/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 5ac6100669c..9658650699f 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -223,20 +223,30 @@ type disk_info = { let parse_disk_info x = match Re.Str.split_delim (Re.Str.regexp "[,]") x with | [source; device_number; rw] -> - let ty, device_number, device_number' = + let maybe_device = match Re.Str.split_delim (Re.Str.regexp "[:]") device_number with | [x] -> - (Vbd.Disk, x, Device_number.of_string false x) + Some (Vbd.Disk, x) | [x; "floppy"] -> - (Vbd.Floppy, x, Device_number.of_string false x) + Some (Vbd.Floppy, x) | [x; "cdrom"] -> - (Vbd.CDROM, x, Device_number.of_string false x) + Some (Vbd.CDROM, x) | _ -> + None + in + let get_position (ty, id) = + Option.map (fun x -> (ty, id, x)) (Device_number.of_string ~hvm:false id) + in + let ty, device_number, position = + match Option.bind maybe_device get_position with + | None -> Printf.fprintf stderr "Failed to understand disk name '%s'. It should be 'xvda' or \ 'hda:cdrom'\n" device_number ; exit 2 + | Some disk -> + disk in let mode = match String.lowercase_ascii rw with @@ -250,7 +260,7 @@ let parse_disk_info x = exit 2 in let backend = parse_source source in - {id= device_number; ty; position= device_number'; mode; disk= backend} + {id= device_number; ty; position; mode; disk= backend} | _ -> Printf.fprintf stderr "I don't understand '%s'. Please use 'phy:path,xvda,w'\n" x ; 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/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index c7fc910ea33..71ad563ed19 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -2629,7 +2629,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) let make_url snippet id_str = Uri.make ?scheme:(Uri.scheme url) ?host:(Uri.host url) ?port:(Uri.port url) - ~path:(Uri.path url ^ snippet ^ id_str) + ~path:(Uri.path_unencoded url ^ snippet ^ id_str) ~query:(Uri.query url) () in (* CA-78365: set the memory dynamic range to a single value to stop @@ -3630,7 +3630,7 @@ module VM = struct debug "traceparent: %s" (Option.value ~default:"(none)" traceparent) ; let id, final_id = (* The URI is /service/xenops/memory/id *) - let bits = Astring.String.cuts ~sep:"/" (Uri.path uri) in + let bits = Astring.String.cuts ~sep:"/" (Uri.path_unencoded uri) in let id = bits |> List.rev |> List.hd in let final_id = match List.assoc_opt "final_id" cookies with @@ -3673,7 +3673,7 @@ module VM = struct (fun () -> let vgpu_id = (* The URI is /service/xenops/migrate-vgpu/id *) - let path = Uri.path uri in + let path = Uri.path_unencoded uri in let bits = Astring.String.cut ~sep:"/" ~rev:true path in let vgpu_id_str = match bits with @@ -3736,7 +3736,7 @@ module VM = struct let dbg = List.assoc "dbg" cookies in Debug.with_thread_associated dbg (fun () -> - let vm = basename (Uri.path uri) in + let vm = basename (Uri.path_unencoded uri) in match context.transferred_fd with | Some fd -> debug "VM.receive_mem: passed fd %d" (Obj.magic fd) ; diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index c12a929392f..c5123641978 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -240,12 +240,20 @@ let add_vbd (vm : Vm.id) (vbd : Vbd.t) () = debug "add_vbd" ; let d = DB.read_exn vm in (* there shouldn't be any None values in here anyway *) - let ps = List.map (fun vbd -> vbd.Vbd.position) d.Domain.vbds in - assert (not (List.mem None ps)) ; - let dns = List.map Option.get ps in - let indices = List.map Device_number.to_disk_number dns in + let dns = List.filter_map (fun vbd -> vbd.Vbd.position) d.Domain.vbds in + let indices = List.map Device_number.disk dns in let next_index = List.fold_left max (-1) indices + 1 in let next_dn = Device_number.of_disk_number d.Domain.hvm next_index in + let next_dn = + match next_dn with + | None -> + raise + (Xenopsd_error + (Internal_error "Ran out of available device numbers for the vbd") + ) + | Some dn -> + dn + in let this_dn = Option.value ~default:next_dn vbd.Vbd.position in if List.mem this_dn dns then ( debug "VBD.plug %s.%s: Already exists" (fst vbd.Vbd.id) (snd vbd.Vbd.id) ; 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/device.ml b/ocaml/xenopsd/xc/device.ml index 20f2405a7e7..3f6da8152a6 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -585,17 +585,18 @@ module Vbd_Common = struct (fun x -> x.frontend.devid |> Device_number.of_xenstore_key - |> Device_number.spec - |> function - | _, disk, _ -> - disk + |> Device_number.disk ) (Device_common.list_frontends ~xs domid) in let next = List.fold_left max 0 disks + 1 in let open Device_number in let bus_type = if hvm && next < 4 then Ide else Xen in - (bus_type, next, 0) + match make bus_type ~disk:next ~partition:0 with + | Some x -> + x + | None -> + raise (Xenopsd_error (Internal_error "Unable to decide slot for vbd")) type t = { mode: mode @@ -620,7 +621,7 @@ module Vbd_Common = struct | Some x -> x | None -> - make (free_device ~xs hvm domid) + free_device ~xs hvm domid in let devid = to_xenstore_key device_number in let device = @@ -2986,7 +2987,11 @@ module Backend = struct qemu-upstream-compat backend *) module Vbd = struct let cd_of devid = - devid |> Device_number.of_xenstore_key |> Device_number.spec |> function + match + ( Device_number.of_xenstore_key devid + :> Device_number.bus_type * int * int + ) + with | Ide, 0, _ -> "ide0-cd0" | Ide, 1, _ -> 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/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 44d4e4e942c..ee4524cf781 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -3774,14 +3774,14 @@ module VBD = struct let qemu_domid = this_domid ~xs in let qemu_frontend = let maybe_create_vbd_frontend () = - let index = Device_number.to_disk_number device_number in + let index = Device_number.disk device_number in match vbd.Vbd.backend with | None -> Some (index, Empty) | Some _ -> Some (index, create_vbd_frontend ~xc ~xs task qemu_domid vdi) in - match Device_number.spec device_number with + match (device_number :> Device_number.bus_type * int * int) with | Ide, n, _ when 0 <= n && n < 4 -> maybe_create_vbd_frontend () | Floppy, n, _ when 0 <= n && n < 2 -> 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 edc8415a473..e4a8379f214 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=302 + N=300 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=514 + N=512 # 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/xe-xentrace b/scripts/xe-xentrace index 94b51bcf134..ff39f3164ba 100755 --- a/scripts/xe-xentrace +++ b/scripts/xe-xentrace @@ -144,7 +144,7 @@ if [ -n "${DUMP_ON_CPUAVG}" ]; then | (TRIGGER=0 read -r _IGNORE while IFS=, read -r _time value; do - if (( $(echo "${value} > ${DUMP_ON_CPUAVG}/100" | bc -l) )); then + if (( $(python3 -c "print(1 if ${value} > ${DUMP_ON_CPUAVG}/100.0 else 0)") )); then TRIGGER=$((TRIGGER + 1)) else TRIGGER=0 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-idl.opam b/xapi-idl.opam index d6e7a390671..1af2c2bd516 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -36,6 +36,7 @@ depends: [ "xapi-open-uri" "xapi-stdext-date" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-tracing" "xapi-inventory" diff --git a/xapi-idl.opam.template b/xapi-idl.opam.template index 6c879e68b97..b07bec320ec 100644 --- a/xapi-idl.opam.template +++ b/xapi-idl.opam.template @@ -34,6 +34,7 @@ depends: [ "xapi-open-uri" "xapi-stdext-date" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-tracing" "xapi-inventory" 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..16dcc46d2b4 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,72 @@ 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" + "qcheck-alcotest" "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 +93,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"}