From 9291f21c0d5b8ab7068b4eb800489403107e7eba Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 18 Jun 2024 13:53:22 +0800 Subject: [PATCH 01/52] CA-394343: After clock jump the xapi assumed the host is HOST_OFFLINE Prior to this commit, the xapi on the coordinator host records the 'Unix.gettimeofday' as the timestamps of the heartbeat with other pool supporter hosts. When the system clock is updated with a huge jump forward, the timestamps would be far back into the past. This would cause the xapi assumes that the hosts are offline as long time no heartbeats. In this commit, the timestamps are changed to get from a monotonic clock. In this way, the system clock changes will not impact the heartbeats' timestamps any more. Additionally, Host_metrics.last_updated is only set when the object is created. It's useless in check_host_liveness at all. Signed-off-by: Ming Lu --- ocaml/xapi/db_gc.ml | 56 +++++++++++++++------------------------- ocaml/xapi/xapi_globs.ml | 6 +++-- ocaml/xapi/xapi_ha.ml | 2 +- 3 files changed, 26 insertions(+), 38 deletions(-) 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/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index ad4f35e37ed..9993b27acdd 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 *) @@ -1070,7 +1070,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) 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 ) ; From 65773251f3817136e4204d110481c8c562c92232 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Tue, 21 May 2024 16:42:56 +0100 Subject: [PATCH 02/52] CP-49634: Add alerting for Corosync upgrade Xapi will send alert when the user is running on a Corosync 2 cluster and prompting them to upgrade. This should only happen on XS 9 and is behind the corosync3 feature flag. XenCenter can take advantage of this alert message, but should have its own warning message to tell the user why/how to perform the upgrade. Signed-off-by: Vincent Liu --- ocaml/xapi-consts/api_messages.ml | 2 + ocaml/xapi/xapi_clustering.ml | 62 +++++++++++++++++++++++++++++-- 2 files changed, 61 insertions(+), 3 deletions(-) diff --git a/ocaml/xapi-consts/api_messages.ml b/ocaml/xapi-consts/api_messages.ml index 5d9160152c2..ff436199a76 100644 --- a/ocaml/xapi-consts/api_messages.ml +++ b/ocaml/xapi-consts/api_messages.ml @@ -311,6 +311,8 @@ let cluster_host_leaving = addMessage "CLUSTER_HOST_LEAVING" 3L let cluster_host_joining = addMessage "CLUSTER_HOST_JOINING" 4L +let cluster_stack_out_of_date = addMessage "CLUSTER_STACK_OUT_OF_DATE" 3L + (* Certificate expiration messages *) let host_server_certificate_expiring = "HOST_SERVER_CERTIFICATE_EXPIRING" diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 21794537268..93a65dadd12 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -540,6 +540,8 @@ module Watcher = struct is an update *) let cluster_change_interval = Mtime.Span.min + let cluster_stack_watcher : bool Atomic.t = Atomic.make false + (* we handle unclean hosts join and leave in the watcher, i.e. hosts joining and leaving due to network problems, power cut, etc. Join and leave initiated by the API will be handled in the API call themselves, but they share the same code @@ -573,22 +575,76 @@ module Watcher = struct done ; Atomic.set cluster_change_watcher false + let watch_cluster_stack_version ~__context ~host = + if !Daemon.enabled then + match find_cluster_host ~__context ~host with + | Some ch -> + let cluster_ref = Db.Cluster_host.get_cluster ~__context ~self:ch in + let cluster_rec = + Db.Cluster.get_record ~__context ~self:cluster_ref + in + if + Cluster_stack.of_version + ( cluster_rec.API.cluster_cluster_stack + , cluster_rec.API.cluster_cluster_stack_version + ) + = Cluster_stack.Corosync2 + then ( + debug "%s: Detected Corosync 2 running as cluster stack" + __FUNCTION__ ; + let body = + "The current cluster stack version of Corosync 2 is out of date, \ + consider updating to Corosync 3" + in + let name, priority = Api_messages.cluster_stack_out_of_date in + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + + Helpers.call_api_functions ~__context (fun rpc session_id -> + let _ : [> `message] Ref.t = + Client.Client.Message.create ~rpc ~session_id ~name ~priority + ~cls:`Host ~obj_uuid:host_uuid ~body + in + () + ) + ) + | None -> + debug "%s: No cluster host, no need to watch" __FUNCTION__ + (** [create_as_necessary] will create cluster watchers on the coordinator if they are not already created. There is no need to destroy them: once the clustering daemon is disabled, these threads will exit as well. *) let create_as_necessary ~__context ~host = - if Helpers.is_pool_master ~__context ~host then + if Helpers.is_pool_master ~__context ~host then ( if Xapi_cluster_helpers.cluster_health_enabled ~__context then if Atomic.compare_and_set cluster_change_watcher false true then ( debug "%s: create watcher for corosync-notifyd on coordinator" __FUNCTION__ ; - ignore - @@ Thread.create (fun () -> watch_cluster_change ~__context ~host) () + let _ : Thread.t = + Thread.create (fun () -> watch_cluster_change ~__context ~host) () + in + () ) else (* someone else must have gone into the if branch above and created the thread before us, leave it to them *) debug "%s: not create watcher for corosync-notifyd as it already exists" + __FUNCTION__ ; + + if Xapi_cluster_helpers.corosync3_enabled ~__context then + if Atomic.compare_and_set cluster_stack_watcher false true then ( + debug + "%s: create cluster stack watcher for out-of-date cluster stack \ + (corosync2)" + __FUNCTION__ ; + let _ : Thread.t = + Thread.create + (fun () -> watch_cluster_stack_version ~__context ~host) + () + in + () + ) else + debug "%s: not create watcher for cluster stack as it already exists" __FUNCTION__ + ) end From f4e944f8d624466cf1981e61807455d1506be683 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 10 Jul 2024 15:57:02 +0100 Subject: [PATCH 03/52] CA-395512: process SMAPIv3 API calls concurrently (default off) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit By default message-switch calls are serialized for backwards compatibility reasons in the Lwt and Async modes. (We tried enabling parallel actions by default but got some hard to debug failures in the CI). This causes very long VM start times when multiple VBDs are plugged/unplugged concurrently: the operations are seen concurrently by message-switch, but xapi-storage-script only retrieves and dispatches them sequentially, so any opportunity for parallel execution is lost. Even though the actions themselves only take seconds, due to serialization, a VM start may take minutes. Enable parallel processing explicitly here (instead of for all message-switch clients). SMAPIv3 should expect to be called concurrently (on different hosts even), so in theory this change should be safe and improve performance, but there are some known bugs in SMAPIv3 plugins currently. So introduce a config file flag 'concurrent' for now, that defaults to false, but that can be turned to 'true' for testing purposes. When all SMAPIv3 concurrency bugs are believed to be fixed we can flip the default, and eventually remove this flag once no more bugs are reported. The configuration value is done as a global to simplify integrating intot he Lwt port, instead of changing a lot of functions to thread through an argument. This doesn't change the behaviour of xapi-storage-script in its default configuration. Signed-off-by: Edwin Török --- ocaml/xapi-storage-script/main.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 2c904af7a43..b9542fd1963 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1693,6 +1693,10 @@ let rec diff a b = | a :: aa -> if List.mem b a ~equal:String.( = ) then diff aa b else a :: diff aa b +(* default false due to bugs in SMAPIv3 plugins, + once they are fixed this should be set to true *) +let concurrent = ref false + let watch_volume_plugins ~volume_root ~switch_path ~pipe = let create volume_plugin_name = if Hashtbl.mem servers volume_plugin_name then @@ -1700,7 +1704,9 @@ let watch_volume_plugins ~volume_root ~switch_path ~pipe = else ( info "Adding %s" volume_plugin_name ; let volume_script_dir = Filename.concat volume_root volume_plugin_name in - Message_switch_async.Protocol_async.Server.listen + Message_switch_async.Protocol_async.Server.( + if !concurrent then listen_p else listen + ) ~process:(process_smapiv2_requests (bind ~volume_script_dir)) ~switch:switch_path ~queue:(Filename.basename volume_plugin_name) @@ -1957,6 +1963,11 @@ let _ = , (fun () -> string_of_bool !self_test_only) , "Do only a self-test and exit" ) + ; ( "concurrent" + , Arg.Set concurrent + , (fun () -> string_of_bool !concurrent) + , "Issue SMAPIv3 calls concurrently" + ) ] in configure2 ~name:"xapi-script-storage" ~version:Xapi_version.version From ccc0f3121ae6632ca702ed2d780ab8b7658f69ba Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 18 Jul 2024 12:56:58 +0100 Subject: [PATCH 04/52] vhd-tool, xen-api-client: Remove duplicated cohttp_unbuffered_io module Signed-off-by: Andrii Sultanov --- ocaml/vhd-tool/src/cohttp_unbuffered_io.ml | 129 ---------- ocaml/vhd-tool/src/dune | 1 + ocaml/vhd-tool/src/impl.ml | 27 ++- .../lwt/cohttp_unbuffered_io.ml | 220 +++++++++--------- ocaml/xen-api-client/lwt/disk.ml | 27 ++- quality-gate.sh | 2 +- 6 files changed, 166 insertions(+), 240 deletions(-) delete mode 100644 ocaml/vhd-tool/src/cohttp_unbuffered_io.ml diff --git a/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml b/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml deleted file mode 100644 index aebc7c1d716..00000000000 --- a/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml +++ /dev/null @@ -1,129 +0,0 @@ -(* - * Copyright (c) 2012 Citrix Inc - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -type 'a t = 'a Lwt.t - -let iter fn x = Lwt_list.iter_s fn x - -let return = Lwt.return - -let ( >>= ) = Lwt.bind - -let ( >> ) m n = m >>= fun _ -> n - -(** Use as few really_{read,write} calls as we can (for efficiency) without - explicitly buffering the stream beyond the HTTP headers. This will - allow us to consume the headers and then pass the file descriptor - safely to another process *) - -type ic = { - mutable header_buffer: string option (** buffered headers *) - ; mutable header_buffer_idx: int (** next char within the buffered headers *) - ; c: Channels.t -} - -let make_input c = - let header_buffer = None in - let header_buffer_idx = 0 in - {header_buffer; header_buffer_idx; c} - -type oc = Channels.t - -type conn = Channels.t - -let really_read_into c buf ofs len = - let tmp = Cstruct.create len in - c.Channels.really_read tmp >>= fun () -> - Cstruct.blit_to_bytes tmp 0 buf ofs len ; - return () - -let read_http_headers c = - let buf = Buffer.create 128 in - (* We can safely read everything up to this marker: *) - let end_of_headers = "\r\n\r\n" in - let tmp = Bytes.make (String.length end_of_headers) '\000' in - let module Scanner = struct - type t = {marker: string; mutable i: int} - - let make x = {marker= x; i= 0} - - let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 - - let remaining x = String.length x.marker - x.i - - let matched x = x.i = String.length x.marker - end in - let marker = Scanner.make end_of_headers in - - let rec loop () = - if not (Scanner.matched marker) then ( - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) - let safe_to_read = Scanner.remaining marker in - - really_read_into c tmp 0 safe_to_read >>= fun () -> - for j = 0 to safe_to_read - 1 do - Scanner.input marker (Bytes.get tmp j) ; - Buffer.add_char buf (Bytes.get tmp j) - done ; - loop () - ) else - return () - in - loop () >>= fun () -> return (Buffer.contents buf) - -(* We assume read_line is only used to read the HTTP header *) -let rec read_line ic = - match (ic.header_buffer, ic.header_buffer_idx) with - | None, _ -> - read_http_headers ic.c >>= fun str -> - ic.header_buffer <- Some str ; - read_line ic - | Some buf, i when i < String.length buf -> ( - match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with - | Some eol -> - let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2 ; - return (Some line) - | None -> - return (Some "") - ) - | Some _, _ -> - return (Some "") - -let read_into_exactly ic buf ofs len = - really_read_into ic.c buf ofs len >>= fun () -> return true - -let read_exactly ic len = - let buf = Bytes.create len in - read_into_exactly ic buf 0 len >>= function - | true -> - return (Some buf) - | false -> - return None - -let read ic n = - let buf = Bytes.make n '\000' in - really_read_into ic.c buf 0 n >>= fun () -> return (Bytes.unsafe_to_string buf) - -let write oc x = - let buf = Cstruct.create (String.length x) in - Cstruct.blit_from_string x 0 buf 0 (String.length x) ; - oc.Channels.really_write buf - -let flush _oc = return () diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 0d8436915ae..3ec83465857 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -30,6 +30,7 @@ tapctl xapi-stdext-std xapi-stdext-unix + xen-api-client-lwt xenstore xenstore.client xenstore.unix diff --git a/ocaml/vhd-tool/src/impl.ml b/ocaml/vhd-tool/src/impl.ml index 6e699650cfc..54058316625 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -954,6 +954,27 @@ let make_stream common source relative_to source_format destination_format = | _, _ -> assert false +module ChannelsConstrained : sig + type t = Channels.t + + type reader = Cstruct.t -> unit Lwt.t + + val really_read : t -> reader + + val really_write : t -> reader +end = struct + type t = Channels.t + + type reader = Cstruct.t -> unit Lwt.t + + let really_read x = x.Channels.really_read + + let really_write x = x.Channels.really_write +end + +module Cohttp_io_with_channels = + Xen_api_client_lwt.Cohttp_unbuffered_io.Make (ChannelsConstrained) + (** [write_stream common s destination destination_protocol prezeroed progress tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites] writes the data stream [s] to [destination], using the specified @@ -1019,8 +1040,8 @@ let write_stream common s destination destination_protocol prezeroed progress Channels.of_raw_fd sock ) >>= fun c -> - let module Request = Request.Make (Cohttp_unbuffered_io) in - let module Response = Response.Make (Cohttp_unbuffered_io) in + let module Request = Request.Make (Cohttp_io_with_channels) in + let module Response = Response.Make (Cohttp_io_with_channels) in let headers = Header.init () in let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in let headers = Header.add headers k v in @@ -1044,7 +1065,7 @@ let write_stream common s destination destination_protocol prezeroed progress Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri' in Request.write (fun _ -> return ()) request c >>= fun () -> - Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r -> + Response.read (Cohttp_io_with_channels.make_input c) >>= fun r -> match r with | `Invalid x -> fail (Failure (Printf.sprintf "Invalid HTTP response: %s" x)) diff --git a/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml b/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml index 935f3e85ccb..ae88acf576c 100644 --- a/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml +++ b/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml @@ -15,117 +15,129 @@ * *) -type 'a t = 'a Lwt.t +module type ChannelType = sig + type t -let iter fn x = Lwt_list.iter_s fn x + type reader = Cstruct.t -> unit Lwt.t -let return = Lwt.return + val really_read : t -> reader -let ( >>= ) = Lwt.bind + val really_write : t -> reader +end -let ( >> ) m n = m >>= fun _ -> n +module Make (Ch : ChannelType) = struct + type 'a t = 'a Lwt.t -(** Use as few really_{read,write} calls as we can (for efficiency) without + let iter fn x = Lwt_list.iter_s fn x + + let return = Lwt.return + + let ( >>= ) = Lwt.bind + + let ( >> ) m n = m >>= fun _ -> n + + (** Use as few really_{read,write} calls as we can (for efficiency) without explicitly buffering the stream beyond the HTTP headers. This will allow us to consume the headers and then pass the file descriptor safely to another process *) -type ic = { - mutable header_buffer: string option (** buffered headers *) - ; mutable header_buffer_idx: int (** next char within the buffered headers *) - ; c: Data_channel.t -} - -let make_input c = - let header_buffer = None in - let header_buffer_idx = 0 in - {header_buffer; header_buffer_idx; c} - -type oc = Data_channel.t - -type conn = Data_channel.t - -let really_read_into c buf ofs len = - let tmp = Cstruct.create len in - c.Data_channel.really_read tmp >>= fun () -> - Cstruct.blit_to_bytes tmp 0 buf ofs len ; - return () - -let read_http_headers c = - let buf = Buffer.create 128 in - (* We can safely read everything up to this marker: *) - let end_of_headers = "\r\n\r\n" in - let tmp = Bytes.make (String.length end_of_headers) '\000' in - let module Scanner = struct - type t = {marker: string; mutable i: int} - - let make x = {marker= x; i= 0} - - let input x c = - if c = String.get x.marker x.i then x.i <- x.i + 1 else x.i <- 0 - - let remaining x = String.length x.marker - x.i - - let matched x = x.i = String.length x.marker - (* let to_string x = Printf.sprintf "%d" x.i *) - end in - let marker = Scanner.make end_of_headers in - - let rec loop () = - if not (Scanner.matched marker) then ( - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) - let safe_to_read = Scanner.remaining marker in - - really_read_into c tmp 0 safe_to_read >>= fun () -> - for j = 0 to safe_to_read - 1 do - Scanner.input marker (Bytes.get tmp j) ; - Buffer.add_char buf (Bytes.get tmp j) - done ; - loop () - ) else - return () - in - loop () >>= fun () -> return (Buffer.contents buf) - -(* We assume read_line is only used to read the HTTP header *) -let rec read_line ic = - match (ic.header_buffer, ic.header_buffer_idx) with - | None, _ -> - read_http_headers ic.c >>= fun str -> - ic.header_buffer <- Some str ; - read_line ic - | Some buf, i when i < String.length buf -> ( - match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with - | Some eol -> - let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2 ; - return (Some line) - | None -> + type ic = { + mutable header_buffer: string option (** buffered headers *) + ; mutable header_buffer_idx: int + (** next char within the buffered headers *) + ; c: Ch.t + } + + let make_input c = + let header_buffer = None in + let header_buffer_idx = 0 in + {header_buffer; header_buffer_idx; c} + + type oc = Ch.t + + type conn = Ch.t + + let really_read_into c buf ofs len = + let tmp = Cstruct.create len in + (Ch.really_read c) tmp >>= fun () -> + Cstruct.blit_to_bytes tmp 0 buf ofs len ; + return () + + let read_http_headers c = + let buf = Buffer.create 128 in + (* We can safely read everything up to this marker: *) + let end_of_headers = "\r\n\r\n" in + let tmp = Bytes.make (String.length end_of_headers) '\000' in + let module Scanner = struct + type t = {marker: string; mutable i: int} + + let make x = {marker= x; i= 0} + + let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 + + let remaining x = String.length x.marker - x.i + + let matched x = x.i = String.length x.marker + end in + let marker = Scanner.make end_of_headers in + + let rec loop () = + if not (Scanner.matched marker) then ( + (* We may be part way through reading the end of header marker, so + be pessimistic and only read enough bytes to read until the end of + the marker. *) + let safe_to_read = Scanner.remaining marker in + + really_read_into c tmp 0 safe_to_read >>= fun () -> + for j = 0 to safe_to_read - 1 do + Scanner.input marker (Bytes.get tmp j) ; + Buffer.add_char buf (Bytes.get tmp j) + done ; + loop () + ) else + return () + in + loop () >>= fun () -> return (Buffer.contents buf) + + (* We assume read_line is only used to read the HTTP header *) + let rec read_line ic = + match (ic.header_buffer, ic.header_buffer_idx) with + | None, _ -> + read_http_headers ic.c >>= fun str -> + ic.header_buffer <- Some str ; + read_line ic + | Some buf, i when i < String.length buf -> ( + match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with + | Some eol -> + let line = String.sub buf i (eol - i) in + ic.header_buffer_idx <- eol + 2 ; + return (Some line) + | None -> + return (Some "") + ) + | Some _, _ -> return (Some "") - ) - | Some _, _ -> - return (Some "") - -let read_into_exactly ic buf ofs len = - really_read_into ic.c buf ofs len >>= fun () -> return true - -let read_exactly ic len = - let buf = Bytes.create len in - read_into_exactly ic buf 0 len >>= function - | true -> - return (Some buf) - | false -> - return None - -let read ic n = - let buf = Bytes.make n '\000' in - really_read_into ic.c buf 0 n >>= fun () -> return (Bytes.unsafe_to_string buf) - -let write oc x = - let buf = Cstruct.create (String.length x) in - Cstruct.blit_from_string x 0 buf 0 (String.length x) ; - oc.Data_channel.really_write buf - -let flush _oc = return () + + let read_into_exactly ic buf ofs len = + really_read_into ic.c buf ofs len >>= fun () -> return true + + let read_exactly ic len = + let buf = Bytes.create len in + read_into_exactly ic buf 0 len >>= function + | true -> + return (Some buf) + | false -> + return None + + let read ic n = + let buf = Bytes.make n '\000' in + really_read_into ic.c buf 0 n >>= fun () -> + return (Bytes.unsafe_to_string buf) + + let write oc x = + let buf = Cstruct.create (String.length x) in + Cstruct.blit_from_string x 0 buf 0 (String.length x) ; + (Ch.really_write oc) buf + + let flush _oc = return () +end diff --git a/ocaml/xen-api-client/lwt/disk.ml b/ocaml/xen-api-client/lwt/disk.ml index fb8f4fc9500..e17a816f94a 100644 --- a/ocaml/xen-api-client/lwt/disk.ml +++ b/ocaml/xen-api-client/lwt/disk.ml @@ -60,6 +60,27 @@ let socket sockaddr = in Lwt_unix.socket family Unix.SOCK_STREAM 0 +module DataChannelConstrained : sig + type t = Data_channel.t + + type reader = Cstruct.t -> unit Lwt.t + + val really_read : t -> reader + + val really_write : t -> reader +end = struct + type t = Data_channel.t + + type reader = Cstruct.t -> unit Lwt.t + + let really_read x = x.Data_channel.really_read + + let really_write x = x.Data_channel.really_write +end + +module Cohttp_io_with_channel = + Cohttp_unbuffered_io.Make (DataChannelConstrained) + let start_upload ~chunked ~uri = Uri_util.sockaddr_of_uri uri >>= fun (sockaddr, use_ssl) -> let sock = socket sockaddr in @@ -74,8 +95,8 @@ let start_upload ~chunked ~uri = Data_channel.of_fd ~seekable:false sock ) >>= fun c -> - let module Request = Request.Make (Cohttp_unbuffered_io) in - let module Response = Response.Make (Cohttp_unbuffered_io) in + let module Request = Request.Make (Cohttp_io_with_channel) in + let module Response = Response.Make (Cohttp_io_with_channel) in let headers = Header.init () in let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in let headers = if chunked then Header.add headers k v else headers in @@ -101,7 +122,7 @@ let start_upload ~chunked ~uri = Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri in Request.write (fun _ -> return ()) request c >>= fun () -> - Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r -> + Response.read (Cohttp_io_with_channel.make_input c) >>= fun r -> match r with | `Eof | `Invalid _ -> fail (Failure "Unable to parse HTTP response from server") diff --git a/quality-gate.sh b/quality-gate.sh index b3cd2e67813..edc8415a473 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=515 + N=514 # 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 '.'" \;) From 6e5893b49452c23b32e1b6ca971a4f85f0fb08c8 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 18 Jul 2024 13:49:32 +0100 Subject: [PATCH 05/52] vhd-tool, ezxenstore: Remove duplicate xenstore module Signed-off-by: Andrii Sultanov --- ocaml/vhd-tool/src/dune | 1 + ocaml/vhd-tool/src/xenstore.ml | 100 +-------------------------------- 2 files changed, 2 insertions(+), 99 deletions(-) diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 3ec83465857..dab81d82c24 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -11,6 +11,7 @@ cohttp cohttp-lwt cstruct + (re_export ezxenstore) io-page lwt lwt.unix diff --git a/ocaml/vhd-tool/src/xenstore.ml b/ocaml/vhd-tool/src/xenstore.ml index 603a86e8f60..b0c0dfd9e8d 100644 --- a/ocaml/vhd-tool/src/xenstore.ml +++ b/ocaml/vhd-tool/src/xenstore.ml @@ -12,102 +12,4 @@ * GNU Lesser General Public License for more details. *) -let error fmt = Printf.ksprintf (output_string stderr) fmt - -module Client = Xs_client_unix.Client (Xs_transport_unix_client) - -let make_client () = - try Client.make () - with e -> - error "Failed to connect to xenstore. The raw error was: %s" - (Printexc.to_string e) ; - ( match e with - | Unix.Unix_error (Unix.EACCES, _, _) -> - error "Access to xenstore was denied." ; - let euid = Unix.geteuid () in - if euid <> 0 then ( - error "My effective uid is %d." euid ; - error "Typically xenstore can only be accessed by root (uid 0)." ; - error "Please switch to root (uid 0) and retry." - ) - | Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> - error "Access to xenstore was refused." ; - error "This normally indicates that the service is not running." ; - error "Please start the xenstore service and retry." - | _ -> - () - ) ; - raise e - -let get_client = - let client = ref None in - fun () -> - match !client with - | None -> - let c = make_client () in - client := Some c ; - c - | Some c -> - c - -type domid = int - -module Xs = struct - type domid = int - - type xsh = { - (* - debug: string list -> string; -*) - directory: string -> string list - ; read: string -> string - ; (* - readv : string -> string list -> string list; -*) - write: string -> string -> unit - ; writev: string -> (string * string) list -> unit - ; mkdir: string -> unit - ; rm: string -> unit - ; (* - getperms : string -> perms; - setpermsv : string -> string list -> perms -> unit; - release : domid -> unit; - resume : domid -> unit; -*) - setperms: string -> Xs_protocol.ACL.t -> unit - ; getdomainpath: domid -> string - ; watch: string -> string -> unit - ; unwatch: string -> string -> unit - ; introduce: domid -> nativeint -> int -> unit - ; set_target: domid -> domid -> unit - } - - let ops h = - { - read= Client.read h - ; directory= Client.directory h - ; write= Client.write h - ; writev= - (fun base_path -> - List.iter (fun (k, v) -> Client.write h (base_path ^ "/" ^ k) v) - ) - ; mkdir= Client.mkdir h - ; rm= (fun path -> try Client.rm h path with Xs_protocol.Enoent _ -> ()) - ; setperms= Client.setperms h - ; getdomainpath= Client.getdomainpath h - ; watch= Client.watch h - ; unwatch= Client.unwatch h - ; introduce= Client.introduce h - ; set_target= Client.set_target h - } - - let with_xs f = Client.immediate (get_client ()) (fun h -> f (ops h)) - - let wait f = Client.wait (get_client ()) (fun h -> f (ops h)) - - let transaction _ f = Client.transaction (get_client ()) (fun h -> f (ops h)) -end - -module Xst = Xs - -let with_xs = Xs.with_xs +include Ezxenstore_core.Xenstore From 56ef633657d391660dd13e9b32c65683cab46e8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 1 Jul 2024 17:19:55 +0100 Subject: [PATCH 06/52] Fix Short/Long duration printing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi/xapi_globs.ml | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 0c2417bb829..8b899e6d054 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1160,15 +1160,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 ) From 857be9e2b25530556277ebbc5b80e4a3c738ac44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 3 Jul 2024 17:48:38 +0100 Subject: [PATCH 07/52] forkexecd: do not clip commandline in logs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit If we want to reproduce a failure we need to know the exact commandline that was used. Longer than 80 chars is not a problem, this is a logfile, and a truncated line is worse than a long line. Signed-off-by: Edwin Török --- ocaml/forkexecd/src/child.ml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) 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 From 71c39605b3a2dd6eddeba42a5b482b4fc1b3a4e8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 8 Jul 2024 14:14:52 +0100 Subject: [PATCH 08/52] CA-395174: Try to unarchive VM's metrics when they aren't running Non-running VMs' metrics are stored in the coordinator. When the coordinator is asked about the metrics try to unarchive them instead of failing while trying to fetch the coordinator's IP address. This needs to force the HTTP method of the query to be POST Also returns a Service Unavailable when the host is marked as Broken. Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/http.ml | 7 +++++++ ocaml/libs/http-lib/http.mli | 2 ++ ocaml/xapi/rrdd_proxy.ml | 30 +++++++++++++++++++++--------- 3 files changed, 30 insertions(+), 9 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c6ff41be709..09dc4a66ed4 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -94,6 +94,13 @@ let http_501_method_not_implemented ?(version = "1.0") () = ; "Cache-Control: no-cache, no-store" ] +let http_503_service_unavailable ?(version = "1.0") () = + [ + Printf.sprintf "HTTP/%s 503 Service Unavailable" version + ; "Connection: close" + ; "Cache-Control: no-cache, no-store" + ] + module Hdr = struct let task_id = "task-id" diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 687c4d2f8c7..384367e2463 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -189,6 +189,8 @@ val http_500_internal_server_error : ?version:string -> unit -> string list val http_501_method_not_implemented : ?version:string -> unit -> string list +val http_503_service_unavailable : ?version:string -> unit -> string list + module Hdr : sig val task_id : string (** Header used for task id *) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index 68b04862f73..fdea2a40373 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -75,17 +75,19 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = Http_svr.headers s (Http.http_302_redirect url) in let unarchive () = - let req = {req with uri= Constants.rrd_unarchive_uri} in + 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 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. *) @@ -97,15 +99,25 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = 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 + let owner_is_available = + is_owner_online owner && not is_xapi_initialising + in + match + (Pool_role.get_role (), is_owner_localhost, owner_is_available) + with + | (Master | Slave _), false, true -> + (* VM is running elsewhere *) + read_at_owner owner + | Master, true, _ | Master, false, false -> + (* VM running on node, or not running at all. *) unarchive () - else + | Slave _, true, _ | Slave _, _, false -> + (* Coordinator knows best *) unarchive_at_master () - else if is_owner_online owner && not is_xapi_initialising then - read_at_owner owner - else - unarchive_at_master () + | 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 From 7fe19554f3dcfa99b4e72015a7c62974a4a19424 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 8 Jul 2024 14:29:40 +0100 Subject: [PATCH 09/52] rrdd_proxy: Change *_at to specify the IP address Forces users to use an address, instead of being implicit, this avoid the underlying cause for the issue fixed in the previous commit: it allowed a coordinator to call Pool_role.get_master_address, which always fails. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rrdd_proxy.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index fdea2a40373..3ca7687f361 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -68,8 +68,7 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = 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 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) @@ -111,9 +110,9 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = | Master, true, _ | Master, false, false -> (* VM running on node, or not running at all. *) unarchive () - | Slave _, true, _ | Slave _, _, false -> + | Slave coordinator, true, _ | Slave coordinator, _, false -> (* Coordinator knows best *) - unarchive_at_master () + unarchive_at coordinator | Broken, _, _ -> info "%s: host is broken, VM's metrics are not available" __FUNCTION__ ; From 6bb7702454f291db6815235c9695f41b4d6b1acf Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 8 Jul 2024 14:54:14 +0100 Subject: [PATCH 10/52] rrdd_proxy: Use Option to encode where VMs might be available at This makes the selection of the action obvious, previously the two booleans made it hazy to understand the decision, and was part of the error why the coordinator tried to get the coordinator address from the pool_role file (and failed badly) Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rrdd_proxy.ml | 50 ++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index 3ca7687f361..bec5ef0f84b 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -63,8 +63,7 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = 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 read_at address = let url = make_url ~address ~req in Http_svr.headers s (Http.http_302_redirect url) in @@ -87,33 +86,38 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = let is_unarchive_request = List.mem_assoc Constants.rrd_unarchive query in - let is_owner_online owner = Db.is_valid_ref __context owner in - let is_xapi_initialising = List.mem_assoc "dbsync" 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* 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 address = Db.Host.get_address ~__context ~self:owner in + Some address + in (* The logic. *) if is_unarchive_request then unarchive () 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 - let owner_is_available = - is_owner_online owner && not is_xapi_initialising - in - match - (Pool_role.get_role (), is_owner_localhost, owner_is_available) - with - | (Master | Slave _), false, true -> - (* VM is running elsewhere *) - read_at_owner owner - | Master, true, _ | Master, false, false -> - (* VM running on node, or not running at all. *) + match (Pool_role.get_role (), metrics_at ()) with + | (Master | Slave _), Some owner -> + read_at owner + | Master, None -> unarchive () - | Slave coordinator, true, _ | Slave coordinator, _, false -> - (* Coordinator knows best *) + | Slave coordinator, None -> unarchive_at coordinator - | Broken, _, _ -> + | Broken, _ -> info "%s: host is broken, VM's metrics are not available" __FUNCTION__ ; unavailable () From 110c1121f1e5faa0baba1028457819688b9a290e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 18 Jul 2024 08:47:06 +0100 Subject: [PATCH 11/52] http-lib: avoid double-queries to the radix tree Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/http_svr.ml | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index d8718bd68a6..26ad35f712f 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -41,6 +41,8 @@ open D module E = Debug.Make (struct let name = "http_internal_errors" end) +let ( let* ) = Option.bind + type uri_path = string module Stats = struct @@ -296,10 +298,7 @@ module Server = struct let add_handler x ty uri handler = let existing = - if MethodMap.mem ty x.handlers then - MethodMap.find ty x.handlers - else - Radix_tree.empty + Option.value (MethodMap.find_opt ty x.handlers) ~default:Radix_tree.empty in x.handlers <- MethodMap.add ty @@ -307,11 +306,9 @@ module Server = struct x.handlers let find_stats x m uri = - if not (MethodMap.mem m x.handlers) then - None - else - let rt = MethodMap.find m x.handlers in - Option.map (fun te -> te.TE.stats) (Radix_tree.longest_prefix uri rt) + let* rt = MethodMap.find_opt m x.handlers in + let* te = Radix_tree.longest_prefix uri rt in + Some te.TE.stats let all_stats x = let open Radix_tree in From 3658806b80ec5f17032fd3b242e98560cc28a5c4 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 19 Jul 2024 13:06:16 +0100 Subject: [PATCH 12/52] rrdd_proxy: Return 400 on bad vm request Currently a List.assoc is used, which raises an unhandled exception. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rrdd_proxy.ml | 130 +++++++++++++++++++-------------------- 1 file changed, 63 insertions(+), 67 deletions(-) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index bec5ef0f84b..a824f77f23a 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -51,76 +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 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* 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 + 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 - let address = Db.Host.get_address ~__context ~self:owner in - Some address + None 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 - 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 () + 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 From c60e482b196d7c4dea6eb34e6cec6dae54d89ce1 Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 11:18:59 +0000 Subject: [PATCH 13/52] CA-394148: Fix dry-run handling in xe-restore-metadata Shell quoting changes in xen-api.git 65f152de687229946eaea6ddcaa5e3d0a11b2b01 broke the dry-run functionality, as by quoting parameters in the way it was done it meant the space separation was not properly handled to separate parameters etc. Signed-off-by: Alex Brett --- scripts/xe-restore-metadata | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 093cd772192..e3bd471e5e2 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -319,8 +319,8 @@ else fi shopt -s nullglob for meta in *.vmmeta; do - echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}" - "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}" + echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} + "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} if [ $? -gt 0 ]; then error_count=$(( $error_count + 1 )) else From 0270f25479bdc9be47ea44b22b94ecfbdf6a6257 Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 11:20:20 +0000 Subject: [PATCH 14/52] CA-393578: Fix vbd cleanup in metadata scripts The xe-[backup,restore]-metadata scripts have cleanup logic designed to ensure we do not leave any vbd objects etc behind. This logic calls `vbd-unplug` with a 20s timeout, and then (regardless of the result) allows up to 10s for any device specified in the VBD to disappear - if it does not, it does not trigger a `vbd-destroy`. This logic fails in the case where a VDI is attached to a VM running on the same host, as the `device` field in the new VBD will be populated with the backend device for the running VM. In this case, the `vbd-unplug` fails immediately (as the vbd is not plugged because the original `vbd-plug` attempt fails as the VDI is in use), but then we sit waiting for 10s for the device to disappear (which is obviously does not), and then fail to trigger a `vbd-destroy`, leaving the VBD behind. Fix this by simply removing the wait for the device to disappear and always attempting a `vbd-destroy`, as I am not aware of any situation where this additional 10s wait will give any benefit given current behaviours. Signed-off-by: Alex Brett --- scripts/xe-backup-metadata | 21 ++------------------- scripts/xe-restore-metadata | 23 +++-------------------- 2 files changed, 5 insertions(+), 39 deletions(-) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 47b21108b9d..86495047b03 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -135,25 +135,8 @@ function cleanup { if [ ! -z "${vbd_uuid}" ]; then ${debug} echo -n "Unplugging VBD: " ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20 - # poll for the device to go away if we know its name - if [ "${device}" != "" ]; then - device_gone=0 - for ((i=0; i<10; i++)); do - ${debug} echo -n "." - if [ ! -b "${device}" ]; then - ${debug} echo " done" - device_gone=1 - break - fi - sleep 1 - done - if [ ${device_gone} -eq 0 ]; then - ${debug} echo " failed" - echo "Please destroy VBD ${vbd_uuid} manually." - else - ${XE} vbd-destroy uuid="${vbd_uuid}" - fi - fi + ${debug} echo -n "Destroying VBD: " + ${XE} vbd-destroy uuid="${vbd_uuid}" fi if [ ${fs_uninitialised} -eq 1 -a -n "${vdi_uuid}" ] ; then ${XE} vdi-destroy uuid="${vdi_uuid}" diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index e3bd471e5e2..ebfb745887f 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -131,26 +131,9 @@ function cleanup { if [ ! -z "${vbd_uuid}" ]; then ${debug} echo -n "Unplugging VBD: " >&2 ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20 - # poll for the device to go away if we know its name - if [ "${device}" != "" ]; then - device_gone=0 - for ((i=0; i<10; i++)); do - ${debug} echo -n "." >&2 - if [ ! -b "${device}" ]; then - ${debug} echo " done" >&2 - device_gone=1 - break - fi - sleep 1 - done - if [ ${device_gone} -eq 0 ]; then - ${debug} echo " failed" >&2 - ${debug} echo "Please destroy VBD ${vbd_uuid} manually." >&2 - else - ${XE} vbd-destroy uuid="${vbd_uuid}" - vbd_uuid="" - fi - fi + ${debug} echo -n "Destroying VBD: " >&2 + ${XE} vbd-destroy uuid="${vbd_uuid}" + vbd_uuid="" device="" fi } From 6fb77381c04c3b3efd354d1fb4cbc294fb336973 Mon Sep 17 00:00:00 2001 From: Alejandro Vallejo Date: Mon, 25 Sep 2023 14:45:27 +0000 Subject: [PATCH 15/52] CA-383491: [Security fix] Use debugfs on xe-restore-metadata probes This patch makes the feature use the debugfs utility, part of e2fsprogs. This makes the system as a whole a heck of a lot better, if only because it won't be able to parse XFS, ReiserFS or any of the many plugins of libfsimage. Signed-off-by: Alejandro Vallejo --- scripts/Makefile | 1 - scripts/probe-device-for-file | 56 ----------------------------------- scripts/xe-restore-metadata | 17 +++++++---- 3 files changed, 11 insertions(+), 63 deletions(-) delete mode 100755 scripts/probe-device-for-file diff --git a/scripts/Makefile b/scripts/Makefile index 18e923c69fa..b47c36f5358 100644 --- a/scripts/Makefile +++ b/scripts/Makefile @@ -121,7 +121,6 @@ install: $(IPROG) print-custom-templates $(DESTDIR)$(LIBEXECDIR) $(IPROG) backup-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) $(IPROG) restore-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) - $(IPROG) probe-device-for-file $(DESTDIR)$(LIBEXECDIR) $(IPROG) backup-metadata-cron $(DESTDIR)$(LIBEXECDIR) $(IPROG) pbis-force-domain-leave $(DESTDIR)$(LIBEXECDIR) mkdir -p $(DESTDIR)/etc/sysconfig diff --git a/scripts/probe-device-for-file b/scripts/probe-device-for-file deleted file mode 100755 index be07f40758f..00000000000 --- a/scripts/probe-device-for-file +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/bin/env python3 -# (c) Anil Madhavapeddy, Citrix Systems Inc, 2008 -# Checks for the existence of a file on a device - -import os, sys -try: - import xenfsimage -except ImportError: - import fsimage as xenfsimage -from contextlib import contextmanager - -# https://stackoverflow.com/a/17954769 -@contextmanager -def stderr_redirected(to=os.devnull): - ''' - import os - - with stderr_redirected(to=filename): - print("from Python") - os.system("echo non-Python applications are also supported") - ''' - fd = sys.stderr.fileno() - - ##### assert that Python and C stdio write using the same file descriptor - ####assert libc.fileno(ctypes.c_void_p.in_dll(libc, "stderr")) == fd == 1 - - def _redirect_stderr(to): - sys.stderr.close() # + implicit flush() - os.dup2(to.fileno(), fd) # fd writes to 'to' file - sys.stderr = os.fdopen(fd, 'w') # Python writes to fd - - with os.fdopen(os.dup(fd), 'w') as old_stderr: - with open(to, 'w') as file: - _redirect_stderr(to=file) - try: - yield # allow code to be run with the redirected stderr - finally: - _redirect_stderr(to=old_stderr) # restore stderr. - # buffering and flags such as - # CLOEXEC may be different - -if __name__ == "__main__": - if len(sys.argv) != 3: - print("Usage: %s " % sys.argv[0]) - sys.exit(2) - device = sys.argv[1] - file = sys.argv[2] - try: - # CA-316241 - fsimage prints to stderr - with stderr_redirected(to="/dev/null"): - fs = xenfsimage.open(device, 0) - if fs.file_exists(file): - os._exit(0) - except: - pass - os._exit(1) diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index ebfb745887f..35fa50b649a 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -2,6 +2,14 @@ # Script which restores metadata into a VDI # Citrix Systems Inc, 2008 +function file_exists() { + local out + out="$(debugfs -R "stat $2" "$1" 2>/dev/null | head -n1 | grep "Type: regular")" + if [ -n "${out}" ]; then + echo y + fi +} + if [ ! -e @INVENTORY@ ]; then echo Must run on a XAPI host. exit 1 @@ -178,22 +186,19 @@ for vdi_uuid in ${vdis}; do ${debug} echo "${device}" >&2 ${debug} echo -n "Probing device: " >&2 - probecmd="@LIBEXECDIR@/probe-device-for-file" - metadata_stamp="/.ctxs-metadata-backup" mnt= - ${probecmd} "${device}" "${metadata_stamp}" - if [ $? -eq 0 ]; then + if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 mnt="/var/run/pool-backup-${vdi_uuid}" mkdir -p "${mnt}" - /sbin/fsck -a "${device}" >/dev/null 2>&1 + /sbin/e2fsck -p -f "${device}" >/dev/null 2>&1 if [ $? -ne 0 ]; then echo "File system integrity error. Please correct manually." >&2 cleanup continue fi - mount "${device}" "${mnt}" >/dev/null 2>&1 + mount -o ro,nosuid,noexec,nodev "${device}" "${mnt}" >/dev/null 2>&1 if [ $? -ne 0 ]; then ${debug} echo failed >&2 cleanup From f51cb8cbe30704a58a1cc6af91838092de326e3c Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 11:26:40 +0000 Subject: [PATCH 16/52] Updates to Portable SR Functionality Add a new option `-o` to xe-restore-metadata, which is used to distinguish whether to allow use of legacy backup VDIs, or enforce only use of the new format VDIs with known UUIDs. Also modify xe-restore-metadata such that it no longer stops searching the candidate list if only one VDI is found, but instead identifies all possible backup VDIs. If more than one is found, and you are doing anything other than listing the VDIs, the script will abort. This is to cover the case where a malicious legacy format VDI is present - we will detect it and the expected 'real' backup VDI. Modify xe-backup-metadata to always expect to use the deterministic UUID to identify the VDI to add backups to, do not rely on the `other-config:ctxs-pool-backup` property for identification in any way. This is XSA-459 / CVE-2024-31144 Signed-off-by: Alex Brett --- scripts/xe-backup-metadata | 32 +------ scripts/xe-restore-metadata | 161 ++++++++++++++++++++++++------------ 2 files changed, 110 insertions(+), 83 deletions(-) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 86495047b03..9aac72573e9 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -55,23 +55,6 @@ function uuid5 { python -c "import uuid; print (uuid.uuid5(uuid.UUID('$1'), '$2'))" } -function validate_vdi_uuid { - # we check that vdi has the expected UUID which depends on the UUID of - # the SR. This is a deterministic hash of the SR UUID and the - # namespace UUID $NS. This UUID must match what Xapi's Uuidx module is using. - local NS="e93e0639-2bdb-4a59-8b46-352b3f408c19" - local sr="$1" - local vdi="$2" - local uuid - - uuid=$(uuid5 "$NS" "$sr") - if [ "$vdi" != "$uuid" ]; then - return 1 - else - return 0 - fi -} - function test_sr { sr_uuid_found=$(${XE} sr-list uuid="$1" --minimal) if [ "${sr_uuid_found}" != "$1" ]; then @@ -120,8 +103,8 @@ fi test_sr "${sr_uuid}" sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label) -# see if a backup VDI already exists on the selected SR -vdi_uuid=$(${XE} vdi-list other-config:ctxs-pool-backup=true sr-uuid="${sr_uuid}" params=uuid --minimal) +# assume use of the new format predictable UUID +vdi_uuid=$(${XE} vdi-list uuid="$(uuid5 "e93e0639-2bdb-4a59-8b46-352b3f408c19" "$sr_uuid")" --minimal) mnt= function cleanup { @@ -143,17 +126,6 @@ function cleanup { fi } -# if we can't validate the UUID of the VDI, prompt the user -if [ -n "${vdi_uuid}" ]; then - if ! validate_vdi_uuid "${sr_uuid}" "${vdi_uuid}" && [ "$yes" -eq 0 ]; then - echo "Backup VDI $vdi_uuid was most likley create by an earlier" - echo "version of this code. Make sure this is a VDI that you" - echo "created as we can't validate it without mounting it." - read -p "Continue? [Y/N]" -n 1 -r; echo - if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi - fi -fi - echo "Using SR: ${sr_name}" if [ -z "${vdi_uuid}" ]; then if [ "${create_vdi}" -gt 0 ]; then diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 35fa50b649a..008c737358e 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -35,11 +35,11 @@ default_restore_mode="all" debug="/bin/true" function usage { - echo "Usage: $0 [-h] [-v] [-y] [-n] [-p] [-f] [-x ] [-u ] [-m all|sr]" + echo "Usage: $0 [-h] [-v] [-y] [-n] [-p] [-f] [-o] [-x ] [-u ] [-m all|sr]" echo echo " -h: Display this help message" echo " -x: Specify the VDI UUID to override probing" - echo " -p: Just scan for a metadata VDI and print out its UUID to stdout" + echo " -p: Just scan for metadata VDI(s) and print out UUID(s) to stdout" echo " -u: UUID of the SR you wish to restore from" echo " -n: Perform a dry run of the metadata import commands (default: false)" echo " -l: Just list the available backup dates" @@ -48,6 +48,7 @@ function usage { echo " -v: Verbose output" echo " -y: Assume non-interactive mode and yes to all questions" echo " -f: Forcibly restore VM metadata, dangerous due to its destructive nature, please always do a dry run before using this (default: false)" + echo " -o: Allow use of legacy backup VDIs (this should not be used with SRs with untrusted VDIs)" echo exit 1 } @@ -75,7 +76,9 @@ just_probe=0 chosen_date="" restore_mode=${default_restore_mode} force=0 -while getopts "yhpvx:d:lnu:m:f" opt ; do +legacy=0 +specified_vdi= +while getopts "yhpvx:d:lnu:m:fo" opt ; do case $opt in h) usage ;; u) sr_uuid=${OPTARG} ;; @@ -85,9 +88,10 @@ while getopts "yhpvx:d:lnu:m:f" opt ; do v) debug="" ;; d) chosen_date=${OPTARG} ;; m) restore_mode=${OPTARG} ;; - x) vdis=${OPTARG} ;; + x) specified_vdi=${OPTARG} ;; y) yes=1 ;; f) force=1 ;; + o) legacy=1 ;; *) echo "Invalid option"; usage ;; esac done @@ -118,16 +122,75 @@ sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label) # probe first for a VDI with known UUID derived from the SR to avoid # scanning for a VDI backup_vdi=$(uuid5 "${NS}" "${sr_uuid}") -if [ -z "${vdis}" ]; then - vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal) + +# Only allow a specified VDI that does not match the known UUID if operating in +# legacy mode +if [ -n "${specified_vdi}" ]; then + if [ "${specified_vdi}" != "${backup_vdi}" ] && [ "$legacy" -eq 0 ]; then + echo "The specified VDI UUID is not permitted, if attempting to use a legacy backup VDI please use the -o flag" >&2 + exit 1 + fi + vdis=${specified_vdi} fi -# get a list of all VDIs if an override has not been provided on the cmd line if [ -z "${vdis}" ]; then - vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal) + if [ "$legacy" -eq 0 ]; then + # In non-legacy mode, only use the known backup_vdi UUID + vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal) + else + # In legacy mode, scan all VDIs + vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal) + fi fi mnt= +vdi_uuid= +vbd_uuid= +device= +function createvbd { + ${debug} echo -n "Creating VBD: " >&2 + vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null) + + if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then + ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2 + cleanup + return 1 + fi + + ${debug} echo "${vbd_uuid}" >&2 + + ${debug} echo -n "Plugging VBD: " >&2 + ${XE} vbd-plug uuid="${vbd_uuid}" + device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device) + + if [ ! -b "${device}" ]; then + ${debug} echo "${device}: not a block special" >&2 + cleanup + return 1 + fi + + ${debug} echo "${device}" >&2 + return 0 +} + +function mountvbd { + mnt="/var/run/pool-backup-${vdi_uuid}" + mkdir -p "${mnt}" + /sbin/fsck -a "${device}" >/dev/null 2>&1 + if [ $? -ne 0 ]; then + echo "File system integrity error. Please correct manually." >&2 + cleanup + return 1 + fi + mount "${device}" "${mnt}" >/dev/null 2>&1 + if [ $? -ne 0 ]; then + ${debug} echo failed >&2 + cleanup + return 1 + fi + return 0 +} + function cleanup { cd / if [ ! -z "${mnt}" ]; then @@ -148,66 +211,34 @@ function cleanup { if [ -z "${vdis}" ]; then echo "No VDIs found on SR." >&2 + if [ "$legacy" -eq 0 ]; then + echo "If you believe there may be a legacy backup VDI present, you can use the -o flag to search for it (this should not be used with untrusted VDIs)" >&2 + fi exit 0 fi trap cleanup SIGINT ERR +declare -a matched_vdis for vdi_uuid in ${vdis}; do - if [ "${vdi_uuid}" != "${backup_vdi}" ] && [ "$yes" -eq 0 ]; then - echo "Probing VDI ${vdi_uuid}." - echo "This VDI was created with a prior version of this code." - echo "Its validity can't be checked without mounting it first." - read -p "Continue? [Y/N]" -n 1 -r; echo - if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi - fi - - ${debug} echo -n "Creating VBD: " >&2 - vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null) - - if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then - ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2 - cleanup - continue - fi - - ${debug} echo "${vbd_uuid}" >&2 - - ${debug} echo -n "Plugging VBD: " >&2 - ${XE} vbd-plug uuid="${vbd_uuid}" - device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device) - - if [ ! -b "${device}" ]; then - ${debug} echo "${device}: not a block special" >&2 - cleanup + createvbd + if [ $? -ne 0 ]; then continue fi - ${debug} echo "${device}" >&2 - ${debug} echo -n "Probing device: " >&2 mnt= if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 - mnt="/var/run/pool-backup-${vdi_uuid}" - mkdir -p "${mnt}" - /sbin/e2fsck -p -f "${device}" >/dev/null 2>&1 + mountvbd if [ $? -ne 0 ]; then - echo "File system integrity error. Please correct manually." >&2 - cleanup continue fi - mount -o ro,nosuid,noexec,nodev "${device}" "${mnt}" >/dev/null 2>&1 - if [ $? -ne 0 ]; then - ${debug} echo failed >&2 - cleanup - else - if [ -e "${mnt}/.ctxs-metadata-backup" ]; then - ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 - xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true - break - fi + + if [ -e "${mnt}/.ctxs-metadata-backup" ]; then + ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 + matched_vdis+=( ${vdi_uuid} ) fi else ${debug} echo "backup metadata not found" >&2 @@ -216,11 +247,35 @@ for vdi_uuid in ${vdis}; do done if [ $just_probe -gt 0 ]; then - echo "${vdi_uuid}" - cleanup + for vdi_uuid in "${matched_vdis[@]}"; do + echo "${vdi_uuid}" + done exit 0 fi +if [ "${#matched_vdis[@]}" -eq 0 ]; then + echo "Metadata backups not found." >&2 + exit 1 +fi + +if [ "${#matched_vdis[@]}" -gt 1 ]; then + echo "Multiple metadata backups found, please use -x to specify the VDI UUID to use" >&2 + exit 1 +fi + +vdi_uuid=${matched_vdis[0]} +xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true +createvbd +if [ $? -ne 0 ]; then + echo "Failure creating VBD for backup VDI ${vdi_uuid}" >&2 + exit 1 +fi +mountvbd +if [ $? -ne 0 ]; then + echo "Failure mounting backup VDI ${vdi_uuid}" >&2 + exit 1 +fi + cd "${mnt}" ${debug} echo "" >&2 From 0a11d0b63985c5ce691a6d6e365a450d8f9d079e Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 12:45:30 +0000 Subject: [PATCH 17/52] Fixes for shellcheck - Quote a parameter - Adjust how we check the returncode of some function calls to satifsy shellcheck - Disable the warnings where we are explicitly relying on string splitting Signed-off-by: Alex Brett --- scripts/xe-restore-metadata | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 008c737358e..5968dc102e8 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -231,14 +231,13 @@ for vdi_uuid in ${vdis}; do if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 - mountvbd - if [ $? -ne 0 ]; then + if ! mountvbd; then continue fi if [ -e "${mnt}/.ctxs-metadata-backup" ]; then ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 - matched_vdis+=( ${vdi_uuid} ) + matched_vdis+=( "${vdi_uuid}" ) fi else ${debug} echo "backup metadata not found" >&2 @@ -265,13 +264,11 @@ fi vdi_uuid=${matched_vdis[0]} xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true -createvbd -if [ $? -ne 0 ]; then +if ! createvbd; then echo "Failure creating VBD for backup VDI ${vdi_uuid}" >&2 exit 1 fi -mountvbd -if [ $? -ne 0 ]; then +if ! mountvbd; then echo "Failure mounting backup VDI ${vdi_uuid}" >&2 exit 1 fi @@ -362,9 +359,10 @@ else fi shopt -s nullglob for meta in *.vmmeta; do + # shellcheck disable=SC2086 echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} - "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} - if [ $? -gt 0 ]; then + # shellcheck disable=SC2086 + if ! "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag}; then error_count=$(( $error_count + 1 )) else good_count=$(( $good_count + 1 )) From 21899964974fff772cc2c1494e0cf17e5066197d Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Fri, 19 Jul 2024 13:58:30 +0000 Subject: [PATCH 18/52] Remove unused `yes` parameter in xe-backup-metadata This parameter was added in 7f1d315135651a84d39f0512fc433f28f3bdba33, but the changes to always use the new metadata VDIs with known UUIDs means it is no longer required, so remove it. Signed-off-by: Alex Brett --- scripts/xe-backup-metadata | 3 --- 1 file changed, 3 deletions(-) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 9aac72573e9..43c4617ec3b 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -39,7 +39,6 @@ function usage { echo " -k: Number of older backups to preserve (default: ${history_kept})" echo " -n: Just try to find a backup VDI and stop the script after that" echo " -f Force backup even when less than 10% free capacity is left on the backup VDI" - echo " -y: Assume non-interactive mode and yes to all questions" echo " -v: Verbose output" echo echo @@ -70,7 +69,6 @@ just_find_vdi=0 fs_uninitialised=0 usage_alert=90 force_backup=0 -yes=0 while getopts "yhvink:u:dcf" opt ; do case $opt in h) usage ;; @@ -81,7 +79,6 @@ while getopts "yhvink:u:dcf" opt ; do d) leave_mounted=1 ;; n) just_find_vdi=1 ;; v) debug="" ;; - y) yes=1 ;; f) force_backup=1 ;; *) echo "Invalid option"; usage ;; esac From 8337fa94b76097428621d1e1987c5d66c1b82095 Mon Sep 17 00:00:00 2001 From: Colin Date: Mon, 22 Jul 2024 13:00:52 +0100 Subject: [PATCH 19/52] Remove ineffectual parameter wiping (#5868) * Remove redundant parameter wiping Removes ineffectual parameter wiping introduced by 6e24ca434fb2e358e. Signed-off-by: Colin James --- ocaml/xapi/xapi_session.ml | 843 ++++++++++++++++++------------------- 1 file changed, 399 insertions(+), 444 deletions(-) diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 1417b4d8313..2a5a933fe6a 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -268,29 +268,14 @@ let set_local_auth_max_threads n = let set_ext_auth_max_threads n = Locking_helpers.Semaphore.set_max throttle_auth_external @@ Int64.to_int n -let wipe_string_contents str = - for i = 0 to Bytes.length str - 1 do - Bytes.set str i '\000' - done - -let wipe ss = List.iter (fun s -> wipe_string_contents s) ss - -(* wrapper that erases sensitive string parameters from functions *) -let wipe_params_after_fn params fn = - try - let r = fn () in - wipe params ; r - with e -> wipe params ; raise e - let do_external_auth uname pwd = with_throttle throttle_auth_external (fun () -> - (Ext_auth.d ()).authenticate_username_password uname - (Bytes.unsafe_to_string pwd) + (Ext_auth.d ()).authenticate_username_password uname pwd ) let do_local_auth uname pwd = with_throttle throttle_auth_internal (fun () -> - try Pam.authenticate uname (Bytes.unsafe_to_string pwd) + try Pam.authenticate uname pwd with Failure msg -> raise Api_errors.(Server_error (session_authentication_failed, [uname; msg])) @@ -298,7 +283,7 @@ let do_local_auth uname pwd = let do_local_change_password uname newpwd = with_throttle throttle_auth_internal (fun () -> - Pam.change_password uname (Bytes.unsafe_to_string newpwd) + Pam.change_password uname newpwd ) let trackid session_id = Context.trackid_of_session (Some session_id) @@ -725,22 +710,19 @@ let slave_local_login ~__context ~psecret = (* Emergency mode login, uses local storage *) let slave_local_login_with_password ~__context ~uname ~pwd = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - let pwd = Bytes.of_string pwd in - wipe_params_after_fn [pwd] (fun () -> - if Context.preauth ~__context <> Some `root then ( - try - (* CP696 - only tries to authenticate against LOCAL superuser account *) - do_local_auth uname pwd - with Failure msg -> - debug "Failed to authenticate user %s: %s" uname msg ; - raise - (Api_errors.Server_error - (Api_errors.session_authentication_failed, [uname; msg]) - ) - ) ; - debug "Add session to local storage" ; - Xapi_local_session.create ~__context ~pool:false - ) + if Context.preauth ~__context <> Some `root then ( + try + (* CP696 - only tries to authenticate against LOCAL superuser account *) + do_local_auth uname pwd + with Failure msg -> + debug "Failed to authenticate user %s: %s" uname msg ; + raise + (Api_errors.Server_error + (Api_errors.session_authentication_failed, [uname; msg]) + ) + ) ; + debug "Add session to local storage" ; + Xapi_local_session.create ~__context ~pool:false (* CP-714: Modify session.login_with_password to first try local super-user login; and then call into external auth plugin if this is enabled @@ -757,415 +739,396 @@ let slave_local_login_with_password ~__context ~uname ~pwd = *) let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = Context.with_tracing ~originator ~__context __FUNCTION__ @@ fun __context -> - let pwd = Bytes.of_string pwd in - wipe_params_after_fn [pwd] (fun () -> - (* !!! Do something with the version number *) - match Context.preauth ~__context with - | Some `root -> - (* in this case, the context origin of this login request is a unix socket bound locally to a filename *) - (* we trust requests from local unix filename sockets, so no need to authenticate them before login *) + (* !!! Do something with the version number *) + match Context.preauth ~__context with + | Some `root -> + (* in this case, the context origin of this login request is a unix socket bound locally to a filename *) + (* we trust requests from local unix filename sockets, so no need to authenticate them before login *) + login_no_password_common ~__context ~uname:(Some uname) ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:"" + ~auth_user_name:uname ~rbac_permissions:[] ~db_ref:None + ~client_certificate:false + | Some `client_cert -> + (* The session was authenticated by stunnel's verification of the client certificate, + so we do not need to verify the username/password. Grant access to functions + based on the special "client_cert" RBAC role. *) + let role = + match + Xapi_role.get_by_name_label ~__context + ~label:Datamodel_roles.role_client_cert + with + | role :: _ -> + role + | [] -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [Datamodel_roles.role_client_cert ^ " role not found"] + ) + ) + in + let rbac_permissions = + Xapi_role.get_permissions_name_label ~__context ~self:role + in + login_no_password_common ~__context ~uname:(Some uname) ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:false ~subject:Ref.null + ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions ~db_ref:None + ~client_certificate:true + | None -> ( + let () = + if Pool_role.is_slave () then + raise + (Api_errors.Server_error + (Api_errors.host_is_slave, [Pool_role.get_master_address ()]) + ) + in + let login_as_local_superuser auth_type = + if auth_type <> "" && uname <> local_superuser then + (* makes local superuser = root only*) + failwith ("Local superuser must be " ^ local_superuser) + else ( + do_local_auth uname pwd ; + debug "Success: local auth, user %s from %s" uname + (Context.get_origin __context) ; login_no_password_common ~__context ~uname:(Some uname) ~originator ~host:(Helpers.get_localhost ~__context) ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions:[] ~db_ref:None ~client_certificate:false - | Some `client_cert -> - (* The session was authenticated by stunnel's verification of the client certificate, - so we do not need to verify the username/password. Grant access to functions - based on the special "client_cert" RBAC role. *) - let role = - match - Xapi_role.get_by_name_label ~__context - ~label:Datamodel_roles.role_client_cert - with - | role :: _ -> - role - | [] -> - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [Datamodel_roles.role_client_cert ^ " role not found"] - ) - ) - in - let rbac_permissions = - Xapi_role.get_permissions_name_label ~__context ~self:role - in - login_no_password_common ~__context ~uname:(Some uname) ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:false ~subject:Ref.null - ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions - ~db_ref:None ~client_certificate:true - | None -> ( - let () = - if Pool_role.is_slave () then - raise - (Api_errors.Server_error - (Api_errors.host_is_slave, [Pool_role.get_master_address ()]) - ) - in - let login_as_local_superuser auth_type = - if auth_type <> "" && uname <> local_superuser then - (* makes local superuser = root only*) - failwith ("Local superuser must be " ^ local_superuser) - else ( - do_local_auth uname pwd ; - debug "Success: local auth, user %s from %s" uname - (Context.get_origin __context) ; - login_no_password_common ~__context ~uname:(Some uname) - ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:true ~subject:Ref.null - ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions:[] - ~db_ref:None ~client_certificate:false + ) + in + let thread_delay_and_raise_error ~error uname msg = + let some_seconds = 5.0 in + Thread.delay some_seconds ; + (* sleep a bit to avoid someone brute-forcing the password *) + if error = Api_errors.session_authentication_failed then + raise (Api_errors.Server_error (error, [uname; msg])) + else if error = Api_errors.session_authorization_failed then + raise Api_errors.(Server_error (error, [uname; msg])) + else + raise + (Api_errors.Server_error + (error, ["session.login_with_password"; msg]) ) - in - let thread_delay_and_raise_error ~error uname msg = - let some_seconds = 5.0 in - Thread.delay some_seconds ; - (* sleep a bit to avoid someone brute-forcing the password *) - if error = Api_errors.session_authentication_failed then - raise (Api_errors.Server_error (error, [uname; msg])) - else if error = Api_errors.session_authorization_failed then - raise Api_errors.(Server_error (error, [uname; msg])) - else - raise - (Api_errors.Server_error - (error, ["session.login_with_password"; msg]) - ) - in - match - Db.Host.get_external_auth_type ~__context - ~self:(Helpers.get_localhost ~__context) - with - | "" as auth_type -> ( - try - (* no external authentication *) + in + match + Db.Host.get_external_auth_type ~__context + ~self:(Helpers.get_localhost ~__context) + with + | "" as auth_type -> ( + try + (* no external authentication *) - (*debug "External authentication is disabled";*) - (* only attempts to authenticate against the local superuser credentials *) - login_as_local_superuser auth_type - with Failure msg -> - info "Failed to locally authenticate user %s from %s: %s" uname + (*debug "External authentication is disabled";*) + (* only attempts to authenticate against the local superuser credentials *) + login_as_local_superuser auth_type + with Failure msg -> + info "Failed to locally authenticate user %s from %s: %s" uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + ) + | _ as auth_type -> ( + (* external authentication required *) + debug "External authentication %s is enabled" auth_type ; + (* 1. first attempts to authenticate against the local superuser *) + try login_as_local_superuser auth_type + with Failure msg -> ( + try + debug "Failed to locally authenticate user %s from %s: %s" uname (Context.get_origin __context) msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname msg - ) - | _ as auth_type -> ( - (* external authentication required *) - debug "External authentication %s is enabled" auth_type ; - (* 1. first attempts to authenticate against the local superuser *) - try login_as_local_superuser auth_type - with Failure msg -> ( + (* 2. then against the external auth service *) + (* 2.1. we first check the external auth service status *) + let rec waiting_event_hook_auth_on_xapi_initialize_succeeded + seconds = + if not !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded + then ( + if seconds <= 0 then ( + let msg = + Printf.sprintf + "External authentication %s service still initializing" + auth_type + in + error "%s" msg ; + thread_delay_and_raise_error uname msg + ~error:Api_errors.internal_error + ) else + debug "External authentication %s service initializing..." + auth_type ; + Thread.delay 1.0 ; + waiting_event_hook_auth_on_xapi_initialize_succeeded + (seconds - 1) + ) + in + waiting_event_hook_auth_on_xapi_initialize_succeeded 120 ; + (* 2.2. we then authenticate the usee using the external authentication plugin *) + (* so that we know that he/she exists there *) + let subject_identifier = try - debug "Failed to locally authenticate user %s from %s: %s" + let _subject_identifier = do_external_auth uname pwd in + debug + "Successful external authentication user %s \ + (subject_identifier, %s from %s)" + uname _subject_identifier + (Context.get_origin __context) ; + _subject_identifier + with Auth_signature.Auth_failure msg -> + info "Failed to externally authenticate user %s from %s: %s" uname (Context.get_origin __context) msg ; - (* 2. then against the external auth service *) - (* 2.1. we first check the external auth service status *) - let rec waiting_event_hook_auth_on_xapi_initialize_succeeded - seconds = - if - not - !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded - then ( - if seconds <= 0 then ( - let msg = - Printf.sprintf - "External authentication %s service still \ - initializing" - auth_type - in - error "%s" msg ; - thread_delay_and_raise_error uname msg - ~error:Api_errors.internal_error - ) else - debug - "External authentication %s service initializing..." - auth_type ; - Thread.delay 1.0 ; - waiting_event_hook_auth_on_xapi_initialize_succeeded - (seconds - 1) - ) - in - waiting_event_hook_auth_on_xapi_initialize_succeeded 120 ; - (* 2.2. we then authenticate the usee using the external authentication plugin *) - (* so that we know that he/she exists there *) - let subject_identifier = - try - let _subject_identifier = do_external_auth uname pwd in - debug - "Successful external authentication user %s \ - (subject_identifier, %s from %s)" - uname _subject_identifier - (Context.get_origin __context) ; - _subject_identifier - with Auth_signature.Auth_failure msg -> - info - "Failed to externally authenticate user %s from %s: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname - msg + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + in + (* as per tests in CP-827, there should be no need to call is_subject_suspended function here, *) + (* because the authentication server in 2.1 will already reflect if account/password expired, *) + (* disabled, locked-out etc, but since likewise doesn't timely reflect this information *) + (* at the same time for both authentication and subject info queries (modification in the AD *) + (* reflects immediately for AD authentication, but can take 1 hour to reflect on subject info), *) + (* we need to call it here in order to be consistent with the session revalidation function. *) + (* Otherwise, there might be cases where the initial authentication/login succeeds, but *) + (* then a few minutes later the revalidation finds that the user is 'suspended' (due to *) + (* subject info caching problems in likewise) and closes the user's session *) + let subject_suspended, subject_name = + try + let suspended, name = + is_subject_suspended ~__context ~cache:true + subject_identifier in - (* as per tests in CP-827, there should be no need to call is_subject_suspended function here, *) - (* because the authentication server in 2.1 will already reflect if account/password expired, *) - (* disabled, locked-out etc, but since likewise doesn't timely reflect this information *) - (* at the same time for both authentication and subject info queries (modification in the AD *) - (* reflects immediately for AD authentication, but can take 1 hour to reflect on subject info), *) - (* we need to call it here in order to be consistent with the session revalidation function. *) - (* Otherwise, there might be cases where the initial authentication/login succeeds, but *) - (* then a few minutes later the revalidation finds that the user is 'suspended' (due to *) - (* subject info caching problems in likewise) and closes the user's session *) - let subject_suspended, subject_name = - try - let suspended, name = - is_subject_suspended ~__context ~cache:true + if suspended then + is_subject_suspended ~__context ~cache:false + subject_identifier + else + (suspended, name) + with Auth_signature.Auth_service_error (_, msg) -> + debug + "Failed to find if user %s (subject_id %s, from %s) is \ + suspended: %s" + uname subject_identifier + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + in + if subject_suspended then ( + let msg = + Printf.sprintf + "User %s (subject_id %s, from %s) suspended in external \ + directory" + uname subject_identifier + (Context.get_origin __context) + in + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + ) else + (* 2.2. then, we verify if any elements of the the membership closure of the externally *) + (* authenticated subject_id is inside our local allowed-to-login subjects list *) + (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) + let group_membership_closure = + try + (Ext_auth.d ()).query_group_membership subject_identifier + with + | Not_found | Auth_signature.Subject_cannot_be_resolved -> + let msg = + Printf.sprintf + "Failed to obtain the group membership closure for \ + user %s (subject_id %s, from %s): user not found in \ + external directory" + uname + (Context.get_origin __context) subject_identifier in - if suspended then - is_subject_suspended ~__context ~cache:false - subject_identifier - else - (suspended, name) - with Auth_signature.Auth_service_error (_, msg) -> + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Auth_signature.Auth_service_error (_, msg) -> debug - "Failed to find if user %s (subject_id %s, from %s) is \ - suspended: %s" + "Failed to obtain the group membership closure for \ + user %s (subject_id %s, from %s): %s" uname subject_identifier (Context.get_origin __context) msg ; thread_delay_and_raise_error ~error:Api_errors.session_authorization_failed uname msg + in + (* finds the intersection between group_membership_closure and pool's table of subject_ids *) + let subjects_in_db = Db.Subject.get_all ~__context in + let subject_ids_in_db = + List.map + (fun subj -> + ( subj + , Db.Subject.get_subject_identifier ~__context ~self:subj + ) + ) + subjects_in_db + in + let reflexive_membership_closure = + subject_identifier :: group_membership_closure + in + (* returns all elements of reflexive_membership_closure that are inside subject_ids_in_db *) + let intersect ext_sids db_sids = + List.filter + (fun (_, db_sid) -> List.mem db_sid ext_sids) + db_sids + in + let intersection = + intersect reflexive_membership_closure subject_ids_in_db + in + (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) + let in_intersection = intersection <> [] in + if not in_intersection then ( + (* empty intersection: externally-authenticated subject has no login rights in the pool *) + let msg = + Printf.sprintf + "Subject %s (identifier %s, from %s) has no access \ + rights in this pool" + uname subject_identifier + (Context.get_origin __context) + in + info "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + ) else (* compute RBAC structures for the session *) + let subject_membership = List.map fst intersection in + debug "subject membership intersection with subject-list=[%s]" + (List.fold_left + (fun i (subj_ref, sid) -> + let subj_ref = + try + (* attempt to resolve subject_ref -> subject_name *) + List.assoc + Auth_signature + .subject_information_field_subject_name + (Db.Subject.get_other_config ~__context + ~self:subj_ref + ) + with _ -> Ref.string_of subj_ref + in + if i = "" then + subj_ref ^ " (" ^ sid ^ ")" + else + i ^ "," ^ subj_ref ^ " (" ^ sid ^ ")" + ) + "" intersection + ) ; + let rbac_permissions = + get_permissions ~__context ~subject_membership in - if subject_suspended then ( + (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) + if rbac_permissions = [] then ( let msg = Printf.sprintf - "User %s (subject_id %s, from %s) suspended in \ - external directory" + "Subject %s (identifier %s) has no roles in this pool" uname subject_identifier - (Context.get_origin __context) in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg + info "%s" msg ; + thread_delay_and_raise_error uname msg + ~error:Api_errors.rbac_permission_denied ) else - (* 2.2. then, we verify if any elements of the the membership closure of the externally *) - (* authenticated subject_id is inside our local allowed-to-login subjects list *) - (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) - let group_membership_closure = + (* non-empty intersection: externally-authenticated subject has login rights in the pool *) + let subject = + (* return reference for the subject obj in the db *) + (* obs: this obj ref can point to either a user or a group contained in the local subject db list *) try - (Ext_auth.d ()).query_group_membership - subject_identifier - with - | Not_found | Auth_signature.Subject_cannot_be_resolved -> - let msg = - Printf.sprintf - "Failed to obtain the group membership closure \ - for user %s (subject_id %s, from %s): user not \ - found in external directory" - uname - (Context.get_origin __context) - subject_identifier - in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname - msg - | Auth_signature.Auth_service_error (_, msg) -> - debug - "Failed to obtain the group membership closure for \ - user %s (subject_id %s, from %s): %s" - uname subject_identifier - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname - msg - in - (* finds the intersection between group_membership_closure and pool's table of subject_ids *) - let subjects_in_db = Db.Subject.get_all ~__context in - let subject_ids_in_db = - List.map - (fun subj -> - ( subj - , Db.Subject.get_subject_identifier ~__context - ~self:subj + List.find + (fun subj -> + (* is this the subject ref that returned the non-empty intersection?*) + List.hd intersection + = ( subj + , Db.Subject.get_subject_identifier ~__context + ~self:subj + ) ) - ) - subjects_in_db - in - let reflexive_membership_closure = - subject_identifier :: group_membership_closure - in - (* returns all elements of reflexive_membership_closure that are inside subject_ids_in_db *) - let intersect ext_sids db_sids = - List.filter - (fun (_, db_sid) -> List.mem db_sid ext_sids) - db_sids - in - let intersection = - intersect reflexive_membership_closure subject_ids_in_db - in - (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) - let in_intersection = intersection <> [] in - if not in_intersection then ( - (* empty intersection: externally-authenticated subject has no login rights in the pool *) - let msg = - Printf.sprintf - "Subject %s (identifier %s, from %s) has no access \ - rights in this pool" - uname subject_identifier - (Context.get_origin __context) - in - info "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - ) else (* compute RBAC structures for the session *) - let subject_membership = List.map fst intersection in - debug - "subject membership intersection with subject-list=[%s]" - (List.fold_left - (fun i (subj_ref, sid) -> - let subj_ref = - try - (* attempt to resolve subject_ref -> subject_name *) - List.assoc - Auth_signature - .subject_information_field_subject_name - (Db.Subject.get_other_config ~__context - ~self:subj_ref - ) - with _ -> Ref.string_of subj_ref - in - if i = "" then - subj_ref ^ " (" ^ sid ^ ")" - else - i ^ "," ^ subj_ref ^ " (" ^ sid ^ ")" - ) - "" intersection - ) ; - let rbac_permissions = - get_permissions ~__context ~subject_membership - in - (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) - if rbac_permissions = [] then ( + subjects_in_db + (* goes through exactly the same subject list that we went when computing the intersection, *) + (* so that no one is able to undetectably remove/add another subject with the same subject_identifier *) + (* between that time 2.2 and now 2.3 *) + with Not_found -> + (* this should never happen, it shows an inconsistency in the db between 2.2 and 2.3 *) let msg = Printf.sprintf - "Subject %s (identifier %s) has no roles in this \ - pool" + "Subject %s (identifier %s, from %s) is not \ + present in this pool" uname subject_identifier + (Context.get_origin __context) in - info "%s" msg ; - thread_delay_and_raise_error uname msg - ~error:Api_errors.rbac_permission_denied - ) else - (* non-empty intersection: externally-authenticated subject has login rights in the pool *) - let subject = - (* return reference for the subject obj in the db *) - (* obs: this obj ref can point to either a user or a group contained in the local subject db list *) - try - List.find - (fun subj -> - (* is this the subject ref that returned the non-empty intersection?*) - List.hd intersection - = ( subj - , Db.Subject.get_subject_identifier ~__context - ~self:subj - ) - ) - subjects_in_db - (* goes through exactly the same subject list that we went when computing the intersection, *) - (* so that no one is able to undetectably remove/add another subject with the same subject_identifier *) - (* between that time 2.2 and now 2.3 *) - with Not_found -> - (* this should never happen, it shows an inconsistency in the db between 2.2 and 2.3 *) - let msg = - Printf.sprintf - "Subject %s (identifier %s, from %s) is not \ - present in this pool" - uname subject_identifier - (Context.get_origin __context) - in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed - uname msg - in - login_no_password_common ~__context ~uname:(Some uname) - ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:false ~subject - ~auth_user_sid:subject_identifier - ~auth_user_name:subject_name ~rbac_permissions - ~db_ref:None ~client_certificate:false - (* we only reach this point if for some reason a function above forgot to catch a possible exception in the Auth_signature module*) - with - | Not_found | Auth_signature.Subject_cannot_be_resolved -> - let msg = - Printf.sprintf - "user %s from %s not found in external directory" uname - (Context.get_origin __context) + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname + msg in - debug - "A function failed to catch this exception for user %s \ - during external authentication: %s" - uname msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - | Auth_signature.Auth_failure msg -> - debug - "A function failed to catch this exception for user %s. \ - Auth_failure: %s" - uname msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname msg - | Auth_signature.Auth_service_error (_, msg) -> - debug - "A function failed to catch this exception for user %s \ - from %s during external authentication: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - | Api_errors.Server_error _ as e -> - (* bubble up any api_error already generated *) - raise e - | e -> - (* generic catch-all for unexpected exceptions during external authentication *) - let msg = ExnHelper.string_of_exn e in - debug - "(generic) A function failed to catch this exception for \ - user %s from %s during external authentication: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.internal_error uname msg - ) - ) + login_no_password_common ~__context ~uname:(Some uname) + ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:false ~subject + ~auth_user_sid:subject_identifier + ~auth_user_name:subject_name ~rbac_permissions + ~db_ref:None ~client_certificate:false + (* we only reach this point if for some reason a function above forgot to catch a possible exception in the Auth_signature module*) + with + | Not_found | Auth_signature.Subject_cannot_be_resolved -> + let msg = + Printf.sprintf + "user %s from %s not found in external directory" uname + (Context.get_origin __context) + in + debug + "A function failed to catch this exception for user %s \ + during external authentication: %s" + uname msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Auth_signature.Auth_failure msg -> + debug + "A function failed to catch this exception for user %s. \ + Auth_failure: %s" + uname msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + | Auth_signature.Auth_service_error (_, msg) -> + debug + "A function failed to catch this exception for user %s from \ + %s during external authentication: %s" + uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Api_errors.Server_error _ as e -> + (* bubble up any api_error already generated *) + raise e + | e -> + (* generic catch-all for unexpected exceptions during external authentication *) + let msg = ExnHelper.string_of_exn e in + debug + "(generic) A function failed to catch this exception for \ + user %s from %s during external authentication: %s" + uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error ~error:Api_errors.internal_error + uname msg + ) ) - ) + ) let change_password ~__context ~old_pwd ~new_pwd = + ignore old_pwd ; Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - let old_pwd = Bytes.of_string old_pwd in - let new_pwd = Bytes.of_string new_pwd in - wipe_params_after_fn [old_pwd; new_pwd] (fun () -> - let session_id = Context.get_session_id __context in - (*let user = Db.Session.get_this_user ~__context ~self:session_id in - let uname = Db.User.get_short_name ~__context ~self:user in*) - let uname = local_superuser in - (* user class has been deprecated *) - if Db.Session.get_is_local_superuser ~__context ~self:session_id then ( - try - (* CP-696: only change password if session has is_local_superuser bit set *) - (* + let session_id = Context.get_session_id __context in + (*let user = Db.Session.get_this_user ~__context ~self:session_id in + let uname = Db.User.get_short_name ~__context ~self:user in*) + let uname = local_superuser in + (* user class has been deprecated *) + if Db.Session.get_is_local_superuser ~__context ~self:session_id then ( + try + (* CP-696: only change password if session has is_local_superuser bit set *) + (* CA-13567: If you have root privileges then we do not authenticate old_pwd; right now, since we only ever have root privileges we just comment this out. @@ -1177,47 +1140,39 @@ let change_password ~__context ~old_pwd ~new_pwd = raise (Api_errors.Server_error (Api_errors.session_authentication_failed,[uname;msg])) end; *) - do_local_change_password uname new_pwd ; - info "Password changed successfully for user %s" uname ; - info "Syncing password change across hosts in pool" ; - (* tell all hosts (except me to sync new passwd file) *) - let hash = Helpers.compute_hash () in - let hosts = Db.Host.get_all ~__context in - let hosts = - List.filter - (fun hostref -> hostref <> !Xapi_globs.localhost_ref) - hosts - in - Helpers.call_api_functions ~__context (fun rpc session_id -> - List.iter - (fun host -> - try - Client.Host.request_config_file_sync ~rpc ~session_id ~host - ~hash - with e -> - error "Failed to sync password to host %s: %s" - (Db.Host.get_name_label ~__context ~self:host) - (Printexc.to_string e) - ) - hosts - ) ; - info "Finished syncing password across pool" - with Failure msg -> - error "Failed to change password for user %s: %s" uname msg ; - raise - (Api_errors.Server_error (Api_errors.change_password_rejected, [msg]) + do_local_change_password uname new_pwd ; + info "Password changed successfully for user %s" uname ; + info "Syncing password change across hosts in pool" ; + (* tell all hosts (except me to sync new passwd file) *) + let hash = Helpers.compute_hash () in + let hosts = Db.Host.get_all ~__context in + let hosts = + List.filter (fun hostref -> hostref <> !Xapi_globs.localhost_ref) hosts + in + Helpers.call_api_functions ~__context (fun rpc session_id -> + List.iter + (fun host -> + try + Client.Host.request_config_file_sync ~rpc ~session_id ~host + ~hash + with e -> + error "Failed to sync password to host %s: %s" + (Db.Host.get_name_label ~__context ~self:host) + (Printexc.to_string e) ) - ) else - (* CP-696: session does not have is_local_superuser bit set, so we must fail *) - let msg = - Printf.sprintf "Failed to change password for user %s" uname - in - debug "User %s is not local superuser: %s" uname msg ; - raise - (Api_errors.Server_error - (Api_errors.user_is_not_local_superuser, [msg]) - ) - ) + hosts + ) ; + info "Finished syncing password across pool" + with Failure msg -> + error "Failed to change password for user %s: %s" uname msg ; + raise + (Api_errors.Server_error (Api_errors.change_password_rejected, [msg])) + ) else + (* CP-696: session does not have is_local_superuser bit set, so we must fail *) + let msg = Printf.sprintf "Failed to change password for user %s" uname in + debug "User %s is not local superuser: %s" uname msg ; + raise + (Api_errors.Server_error (Api_errors.user_is_not_local_superuser, [msg])) let logout ~__context = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> From f39ea999fcde62a48d485ccd20becf9c610d6231 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 15:27:16 +0100 Subject: [PATCH 20/52] CP-47536: Drop posix_channel and channel_helper: unused and a mix of Unix/Lwt MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It was a mix of Lwt and Unix code, which means that if the Unix call blocks the entire Lwt code blocks too. This was only installed by the specfile in a -devel package. `message-cli tail --follow` can be used to debug the IDL protocol instead. Signed-off-by: Edwin Török --- ocaml/xapi-idl/README.md | 1 - ocaml/xapi-idl/lib/posix_channel.ml | 234 ------------------------ ocaml/xapi-idl/lib/posix_channel.mli | 21 --- ocaml/xapi-idl/lib/xcp_channel.ml | 17 -- ocaml/xapi-idl/lib/xcp_channel.mli | 13 -- ocaml/xapi-idl/lib_test/channel_test.ml | 77 -------- ocaml/xapi-idl/misc/channel_helper.ml | 221 ---------------------- ocaml/xapi-idl/misc/dune | 16 -- quality-gate.sh | 2 +- 9 files changed, 1 insertion(+), 601 deletions(-) delete mode 100644 ocaml/xapi-idl/lib/posix_channel.ml delete mode 100644 ocaml/xapi-idl/lib/posix_channel.mli delete mode 100644 ocaml/xapi-idl/lib/xcp_channel.ml delete mode 100644 ocaml/xapi-idl/lib/xcp_channel.mli delete mode 100644 ocaml/xapi-idl/lib_test/channel_test.ml delete mode 100644 ocaml/xapi-idl/misc/channel_helper.ml delete mode 100644 ocaml/xapi-idl/misc/dune 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/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/xcp_channel.ml b/ocaml/xapi-idl/lib/xcp_channel.ml deleted file mode 100644 index 395da851a5f..00000000000 --- a/ocaml/xapi-idl/lib/xcp_channel.ml +++ /dev/null @@ -1,17 +0,0 @@ -type t = Unix.file_descr - -let file_descr_of_t t = t - -let t_of_file_descr t = t - -[@@@ocaml.warning "-34"] - -type protocols = Xcp_channel_protocol.t list [@@deriving rpc] - -let rpc_of_t fd = - let protocols = Posix_channel.send fd in - rpc_of_protocols protocols - -let t_of_rpc x = - let protocols = protocols_of_rpc x in - Posix_channel.receive protocols diff --git a/ocaml/xapi-idl/lib/xcp_channel.mli b/ocaml/xapi-idl/lib/xcp_channel.mli deleted file mode 100644 index 35849a1e5d4..00000000000 --- a/ocaml/xapi-idl/lib/xcp_channel.mli +++ /dev/null @@ -1,13 +0,0 @@ -type t - -val rpc_of_t : t -> Rpc.t - -val t_of_rpc : Rpc.t -> t - -val file_descr_of_t : t -> Unix.file_descr - -val t_of_file_descr : Unix.file_descr -> t - -val protocols_of_rpc : Rpc.t -> Xcp_channel_protocol.t list - -val rpc_of_protocols : Xcp_channel_protocol.t list -> Rpc.t diff --git a/ocaml/xapi-idl/lib_test/channel_test.ml b/ocaml/xapi-idl/lib_test/channel_test.ml deleted file mode 100644 index dd607935778..00000000000 --- a/ocaml/xapi-idl/lib_test/channel_test.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* - * Copyright (C) 2011-2013 Citrix Inc - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -let dup_automatic x = - let x = Xcp_channel.t_of_file_descr x in - let y = Xcp_channel.rpc_of_t x in - let z = Xcp_channel.t_of_rpc y in - Xcp_channel.file_descr_of_t z - -let dup_sendmsg x = - let protos = Posix_channel.send x in - let proto = - List.find - (function - | Xcp_channel_protocol.Unix_sendmsg (_, _, _) -> true | _ -> false - ) - protos - in - Posix_channel.receive [proto] - -let count_fds () = Array.length (Sys.readdir "/proc/self/fd") - -(* dup stdout, check /proc/pid/fd *) -let check_for_leak dup_function () = - let before = count_fds () in - let stdout2 = dup_function Unix.stdout in - let after = count_fds () in - Alcotest.(check int) "fds" (before + 1) after ; - Unix.close stdout2 ; - let after' = count_fds () in - Alcotest.(check int) "fds" before after' - -let dup_proxy x = - let protos = Posix_channel.send x in - let proto = - List.find - (function - | Xcp_channel_protocol.TCP_proxy (_ip, _port) -> true | _ -> false - ) - protos - in - Posix_channel.receive [proto] - -let check_for_leak_proxy () = - let a, _b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - let before = count_fds () in - let c = dup_proxy a in - (* background fd closing *) - Thread.delay 1.0 ; - let after = count_fds () in - Alcotest.(check int) "fds" (before + 2) after ; - Unix.close c ; - (* background fd closing *) - Thread.delay 1.0 ; - let after' = count_fds () in - Alcotest.(check int) "fds" before after' - -let tests = - [ - ( "check_for_leak with automatic selection" - , `Quick - , check_for_leak dup_automatic - ) - ; ("check_for_leak with sendmsg", `Quick, check_for_leak dup_sendmsg) - ; ("check_for_leak_proxy", `Quick, check_for_leak_proxy) - ] diff --git a/ocaml/xapi-idl/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/quality-gate.sh b/quality-gate.sh index edc8415a473..be4e470fc94 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -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 '.'" \;) From d3460a35122d0ea5e6faaed470d7755bf34d74c8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 22 Jul 2024 15:37:37 +0100 Subject: [PATCH 21/52] opam: dunify vhd-tool's metadata Also add missing dependencies added recently Signed-off-by: Pau Ruiz Safont --- dune-project | 26 +++++++++++++++++++++ vhd-tool.opam | 52 ++++++++++++++++++++++++------------------ vhd-tool.opam.template | 40 -------------------------------- 3 files changed, 56 insertions(+), 62 deletions(-) delete mode 100644 vhd-tool.opam.template diff --git a/dune-project b/dune-project index 6d0c661ee31..fde96410f19 100644 --- a/dune-project +++ b/dune-project @@ -321,6 +321,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 diff --git a/vhd-tool.opam b/vhd-tool.opam index c1f8135c98d..9549a608df3 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.0"} "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" -} From 541c03dcab7370a86bf023e57bb82e8695764e16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 10 May 2024 11:47:50 +0100 Subject: [PATCH 22/52] CP-47536: replace Protocol_unix.scheduler.Delay with Threadext.Delay MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Its implementation was identical, except for the use of time_limited_read in Threadext, but the semantics is identical. Use one well tested implementation instead of duplicating code. One less function to convert to epoll. Signed-off-by: Edwin Török --- message-switch-unix.opam | 1 + ocaml/message-switch/unix/dune | 1 + .../unix/protocol_unix_scheduler.ml | 66 +------------------ 3 files changed, 3 insertions(+), 65 deletions(-) diff --git a/message-switch-unix.opam b/message-switch-unix.opam index 64fd72db241..67b0bd817e3 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.opam @@ -19,6 +19,7 @@ depends: [ "base-threads" "message-switch-core" "ppx_deriving_rpc" + "xapi-stdext-unix" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/ocaml/message-switch/unix/dune b/ocaml/message-switch/unix/dune index 54b6c0e77bf..3e088a12556 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -11,6 +11,7 @@ rpclib.core rpclib.json threads.posix + xapi-stdext-threads ) (preprocess (pps ppx_deriving_rpc)) ) 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} From d9590a0b341a88b3b047b2a4c4945954535ca10b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 10 Jun 2024 17:19:05 +0100 Subject: [PATCH 23/52] fix(xapi-idl): replace PipeDelay with Delay, avoid another Thread.wait_timed_read MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-idl/lib/scheduler.ml | 28 +--------------------------- 1 file changed, 1 insertion(+), 27 deletions(-) diff --git a/ocaml/xapi-idl/lib/scheduler.ml b/ocaml/xapi-idl/lib/scheduler.ml index 407120c9fc6..d4d5c7c5cca 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 From 4f587b0b7f9ff452195bd8d889bed123e70a8b4e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 22 Jul 2024 16:39:25 +0100 Subject: [PATCH 24/52] opam: dunify message-switch-unix's metadata Signed-off-by: Pau Ruiz Safont --- dune-project | 10 ++++++ message-switch-unix.opam | 51 +++++++++++++++++-------------- message-switch-unix.opam.template | 27 ---------------- 3 files changed, 38 insertions(+), 50 deletions(-) delete mode 100644 message-switch-unix.opam.template diff --git a/dune-project b/dune-project index fde96410f19..481ea148048 100644 --- a/dune-project +++ b/dune-project @@ -464,6 +464,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/message-switch-unix.opam b/message-switch-unix.opam index 67b0bd817e3..cd086195cb2 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.opam @@ -1,30 +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.0"} "base-threads" - "message-switch-core" + "cohttp" + "message-switch-core" {= version} "ppx_deriving_rpc" - "xapi-stdext-unix" + "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" -} From d88017e65c4eb814f7a522b11f3f952664c57c70 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 22 Jul 2024 10:42:25 +0100 Subject: [PATCH 25/52] IH-507: xapi_xenops: raise an error when the kernel isn't allowed Previously the path was replaced by an empty string, when trying to start he vm. The only feedback was on the logs as a debug message, but not all users that start VMs have access to the logs. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/xapi_xenops.ml | 110 +++++++++++++++++++------------------- 1 file changed, 54 insertions(+), 56 deletions(-) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 50aa2c6c53d..1da207c74f8 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -337,19 +337,43 @@ 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/ *) +(* /boot/ contains potentially sensitive files like xen-initrd, 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 + ["/boot/guest/"; "/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 +396,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 +444,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 +456,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 +473,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) From 5dc2900f1f808c2b49a6ecbda3720b0b8d70a917 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 23 Jul 2024 11:23:07 +0100 Subject: [PATCH 26/52] IH-507: Do not allow guest kernels in /boot/ This location is for dom0's boot chain exclusively Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/xapi_xenops.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 1da207c74f8..cb1932aab0a 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -337,10 +337,7 @@ let rtc_timeoffset_of_vm ~__context (vm, vm_t) vbds = ) ) -(* /boot/ contains potentially sensitive files like xen-initrd, only allow - directly booting guests from the subfolder /boot/guest/ *) -let allowed_dom0_directories_for_boot_files = - ["/boot/guest/"; "/var/lib/xcp/guest/"] +let allowed_dom0_directories_for_boot_files = ["/var/lib/xcp/guest/"] let kernel_path filename = let ( let* ) = Result.bind in From a7b7a26bc1b1bba52ee1d6d82177fc2dca99f56c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:32 +0000 Subject: [PATCH 27/52] [maintenance] bump minimum dune language version to 3.7 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Some features of Dune are only available when a new language version is used (e.g. 'package' for 'library' stanzas would require bumping this to 2.8). Defaults also change, e.g. 3.0+ enables `executables_implicit_empty_intf` which can be beneficial for finding dead code in executables. But more importantly Dune versions <3.7 have a binary corruption bug with executable promotion that got fixed here: https://github.com/ocaml/dune/commit/f0c708c83abd1b20313f779aefcb65410110052f Require dune >= 3.7. The version bumps also comes with many more unused warnings enabled by default, turn these back into warnings and do not fail the build. (Once they are fixed we can remove the -warn-error list) No functional change. Signed-off-by: Edwin Török --- dune | 2 +- dune-project | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) 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 481ea148048..59624a34056 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,5 @@ -(lang dune 3.0) +(lang dune 3.7) + (formatting (enabled_for ocaml)) (using menhir 2.0) From 5353e3e5c58335dda9bb38ad074c51620cd88960 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 23 Jul 2024 09:22:58 +0100 Subject: [PATCH 28/52] [maintenance]: bump dune language version to 3.15 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is the version we currently use in xs-opam. Newer dune version may also come with more warnings enabled by default. Signed-off-by: Edwin Török --- dune-project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dune-project b/dune-project index 59624a34056..ad3b41392d1 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.7) +(lang dune 3.15) (formatting (enabled_for ocaml)) (using menhir 2.0) From d802d43adb93ea845ce8888a6822bb16d6380242 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:32 +0000 Subject: [PATCH 29/52] [maintenance] regenerate opam after dune version bump MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit No functional change. Signed-off-by: Edwin Török --- clock.opam | 2 +- forkexec.opam | 2 +- http-lib.opam | 2 +- message-switch-core.opam | 2 +- message-switch-unix.opam | 2 +- message-switch.opam | 1 + message-switch.opam.template | 1 + rrd-transport.opam | 2 +- rrdd-plugin.opam | 2 +- vhd-format-lwt.opam | 2 +- vhd-tool.opam | 2 +- wsproxy.opam | 2 +- xapi-forkexecd.opam | 2 +- xapi-networkd.opam | 2 +- xapi-rrd-transport-utils.opam | 2 +- xapi-rrdd.opam | 2 +- xapi-sdk.opam | 2 +- xapi-stdext-date.opam | 2 +- xapi-stdext-encodings.opam | 2 +- xapi-stdext-pervasives.opam | 2 +- xapi-stdext-std.opam | 2 +- xapi-stdext-threads.opam | 2 +- xapi-stdext-unix.opam | 2 +- xapi-stdext-zerocheck.opam | 2 +- xapi-tracing-export.opam | 2 +- xapi-tracing.opam | 2 +- xen-api-client.opam | 2 +- 27 files changed, 27 insertions(+), 25 deletions(-) diff --git a/clock.opam b/clock.opam index 44c24235c58..52cc8d0ef09 100644 --- a/clock.opam +++ b/clock.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"} "alcotest" {with-test} "astring" 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 cd086195cb2..c9379979e2d 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.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"} "base-threads" "cohttp" "message-switch-core" {= version} 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/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/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 9549a608df3..f0135ab7a41 100644 --- a/vhd-tool.opam +++ b/vhd-tool.opam @@ -8,7 +8,7 @@ tags: ["org.mirage" "org:xapi-project"] homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest-lwt" {with-test} "cohttp-lwt" "conf-libssl" diff --git a/wsproxy.opam b/wsproxy.opam index 9e9def30a82..0d9e79c096c 100644 --- a/wsproxy.opam +++ b/wsproxy.opam @@ -7,7 +7,7 @@ license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "base64" {>= "3.1.0"} "fmt" diff --git a/xapi-forkexecd.opam b/xapi-forkexecd.opam index 900419be134..6f2ccbffdb8 100644 --- a/xapi-forkexecd.opam +++ b/xapi-forkexecd.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "astring" "forkexec" {= version} "uuid" {= version} diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 595478821f2..ef37bd16486 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "base-threads" diff --git a/xapi-rrd-transport-utils.opam b/xapi-rrd-transport-utils.opam index 261da91a4e3..754b956f157 100644 --- a/xapi-rrd-transport-utils.opam +++ b/xapi-rrd-transport-utils.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" "cmdliner" "rrd-transport" {= version} diff --git a/xapi-rrdd.opam b/xapi-rrdd.opam index 0782309fe06..8ec47c8322d 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.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" {>= "4.02.0"} "dune-build-info" "alcotest" {with-test} 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/xen-api-client.opam b/xen-api-client.opam index 3c31159d66c..c9fa73d8cf6 100644 --- a/xen-api-client.opam +++ b/xen-api-client.opam @@ -15,7 +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" {>= "3.15"} "dune-build-info" "alcotest" {with-test} "astring" From 197adc943d2c2881a7c89596870a88d273082f18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:33 +0000 Subject: [PATCH 30/52] [maintenance]: do not build bytecode versions of internal libraries MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Only build 'best' (which may be bytecode if native is not available). Note that this does not prevent the use of 'dune utop': it will build bytecode libraries as needed, they are just not built by default. (And since they are internal libraries they wouldn't get installed anyway) Signed-off-by: Edwin Török --- ocaml/alerts/certificate/dune | 1 + ocaml/auth/dune | 1 + ocaml/gencert/dune | 1 + ocaml/license/dune | 1 + ocaml/nbd/lib/dune | 3 +++ ocaml/networkd/lib/dune | 1 + ocaml/networkd/test/dune | 1 + ocaml/sdk-gen/common/dune | 1 + ocaml/squeezed/lib/dune | 1 + ocaml/tapctl/dune | 1 + ocaml/vhd-tool/src/dune | 1 + ocaml/wsproxy/src/dune | 1 + ocaml/xapi-aux/dune | 1 + ocaml/xapi-guard/lib/dune | 3 ++- ocaml/xenopsd/xc/dune | 1 + ocaml/xs-trace/dune | 2 +- ocaml/xs-trace/test/dune | 2 +- ocaml/xxhash/lib/dune | 1 + ocaml/xxhash/stubs/dune | 1 + unixpwd/src/dune | 1 + 20 files changed, 23 insertions(+), 3 deletions(-) diff --git a/ocaml/alerts/certificate/dune b/ocaml/alerts/certificate/dune index d3743285e77..e3ef3de0aee 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 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/gencert/dune b/ocaml/gencert/dune index fedcfefc04e..f859078e89a 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 diff --git a/ocaml/license/dune b/ocaml/license/dune index 28ce39eb80f..8981c7c0bef 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 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/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..06c39333171 100644 --- a/ocaml/networkd/test/dune +++ b/ocaml/networkd/test/dune @@ -1,5 +1,6 @@ (executable (name network_test) + (modes exe) (libraries alcotest astring 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/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/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/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index dab81d82c24..02de3dbcce3 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) 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..f35495d6284 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -1,5 +1,6 @@ (library (name xapi_aux) + (modes best) (libraries astring cstruct diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index dd35baf40cb..000ca654c04 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 diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 7fedcaa3207..8fbc258df32 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 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/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/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 ) From ac6b7b4755899313414d6716d4b6928ea6809a1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 16:54:10 +0100 Subject: [PATCH 31/52] [maintenance]: add server.mli MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Speeds up the build, together with the previous commit. Now we no longer need to build bytecode version of server.ml. A similar approach might be useful for db_actions and client, but those would have to be generated automatically. ``` hyperfine --min-runs 3 'dune clean; dune build --cache=disabled' 'cd ../scm-prev; dune clean; dune build --cache=disabled' Benchmark 1: dune clean; dune build --cache=disabled Time (mean ± σ): 79.936 s ± 0.666 s [User: 343.353 s, System: 116.654 s] Range (min … max): 79.373 s … 80.671 s 3 runs Benchmark 2: cd ../scm-prev; dune clean; dune build --cache=disabled Time (mean ± σ): 91.555 s ± 0.613 s [User: 355.560 s, System: 118.064 s] Range (min … max): 91.083 s … 92.248 s 3 runs Summary dune clean; dune build --cache=disabled ran 1.15 ± 0.01 times faster than cd ../scm-prev; dune clean; dune build --cache=disabled ``` Signed-off-by: Edwin Török --- ocaml/xapi/server.mli | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 ocaml/xapi/server.mli 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 From ed780881a5bcb70e8b2e5112f1251e18af8a628a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 32/52] [maintenance]: xapi-aux does not need to depend on xapi-types MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-aux/dune | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml/xapi-aux/dune b/ocaml/xapi-aux/dune index f35495d6284..86fbd8647c9 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -15,7 +15,6 @@ xapi-log xapi-stdext-threads xapi-stdext-unix - xapi-types xml-light2 ) (wrapped false) From f07b9d7d7a57b85797486f5c306db5c02d2dba32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 33/52] [maintenance]: preprocess only modules containing @@deriving MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reduces the amount of work the build has to do if we don't need to preprocess everything, but only the few modules that actually using [@@deriving]. Signed-off-by: Edwin Török --- ocaml/database/dune | 7 +++++-- ocaml/forkexecd/lib/dune | 3 +-- ocaml/idl/dune | 2 +- ocaml/message-switch/core/dune | 2 +- ocaml/message-switch/switch/dune | 2 +- ocaml/message-switch/unix/dune | 2 +- ocaml/tests/dune | 1 - ocaml/vhd-tool/src/dune | 5 ++++- ocaml/xapi-guard/lib/dune | 2 +- ocaml/xapi-idl/lib/dune | 7 +++++-- ocaml/xapi-idl/lib_test/dune | 2 +- ocaml/xapi-storage/generator/lib/dune | 3 ++- ocaml/xapi-types/dune | 2 +- ocaml/xapi/dune | 8 +++++++- ocaml/xcp-rrdd/bin/rrdd/dune | 1 - ocaml/xcp-rrdd/test/rrdd/dune | 1 - ocaml/xen-api-client/lib/dune | 1 - ocaml/xenopsd/cli/dune | 2 +- ocaml/xenopsd/lib/dune | 5 ++++- ocaml/xenopsd/test/dune | 2 +- ocaml/xenopsd/xc/dune | 4 +++- 21 files changed, 40 insertions(+), 24 deletions(-) diff --git a/ocaml/database/dune b/ocaml/database/dune index 08108ad6c55..bdc5cea531a 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -16,7 +16,7 @@ xapi-stdext-encodings ) (wrapped false) - (preprocess (pps ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_sexp_conv) Schema))) ) (library @@ -50,7 +50,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 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/idl/dune b/ocaml/idl/dune index 837c3b0013a..0a3aab54c24 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -21,7 +21,7 @@ xapi-stdext-unix ) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Datamodel_types))) ) (executable 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/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/unix/dune b/ocaml/message-switch/unix/dune index 3e088a12556..be953217f4e 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -13,6 +13,6 @@ threads.posix xapi-stdext-threads ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Protocol_unix_scheduler))) ) diff --git a/ocaml/tests/dune b/ocaml/tests/dune index d48056d3b70..9283fc9af16 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -52,7 +52,6 @@ xapi-xenopsd xml-light2 ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) (deps (source_tree test_data) ) diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 02de3dbcce3..8d278eefa07 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -39,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/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index 000ca654c04..e4eebc4cd80 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -52,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-idl/lib/dune b/ocaml/xapi-idl/lib/dune index c8feec1ff1a..29ea321bce3 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -38,7 +38,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 +63,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_test/dune b/ocaml/xapi-idl/lib_test/dune index 57c8c95e592..0806453c035 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -50,4 +50,4 @@ xapi-idl.xen.interface.types xapi-log ) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Task_server_test Updates_test)))) diff --git a/ocaml/xapi-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..12d1703ce3d 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -24,6 +24,6 @@ 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/dune b/ocaml/xapi/dune index 22b37b509ac..301ea77ccbd 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -162,7 +162,13 @@ 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))) ) (executable diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 29142383a22..d1a38196462 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -33,7 +33,6 @@ xmlm yojson ) - (preprocess (pps ppx_deriving_rpc)) ) (executable diff --git a/ocaml/xcp-rrdd/test/rrdd/dune b/ocaml/xcp-rrdd/test/rrdd/dune index 699ae424bfe..92c674df715 100644 --- a/ocaml/xcp-rrdd/test/rrdd/dune +++ b/ocaml/xcp-rrdd/test/rrdd/dune @@ -10,6 +10,5 @@ xapi-idl.rrd xapi-rrd ) - (preprocess (pps ppx_deriving_rpc)) ) 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/xenopsd/cli/dune b/ocaml/xenopsd/cli/dune index b194b10323c..d8482fced6e 100644 --- a/ocaml/xenopsd/cli/dune +++ b/ocaml/xenopsd/cli/dune @@ -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/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/test/dune b/ocaml/xenopsd/test/dune index 6c793a3c1bd..e795d7295bf 100644 --- a/ocaml/xenopsd/test/dune +++ b/ocaml/xenopsd/test/dune @@ -20,7 +20,7 @@ xenstore_transport.unix ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module ((pps ppx_deriving_rpc) Test)) ) ) diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 8fbc258df32..c1727b4493e 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -57,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) ) From d3869c15c7846fe738fe13ffd99b857e5d00761c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 34/52] [maintenance]: split server.ml into separate library MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/tests/common/dune | 1 + ocaml/tests/dune | 2 ++ ocaml/xapi/dune | 38 +++++++++++++++++++++++++++++++++++++- 3 files changed, 40 insertions(+), 1 deletion(-) diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index c578f5f9785..fff8623dee9 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -21,6 +21,7 @@ xapi-idl.network xapi-idl.xen.interface xapi_internal + xapi_internal_server xapi-inventory xapi-log xapi-test-utils diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 9283fc9af16..81a977cfaa3 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -40,6 +40,7 @@ xapi-idl.xen.interface xapi-idl.xen.interface.types xapi_internal + xapi_internal_server xapi-log xapi-stdext-date xapi-stdext-std @@ -88,6 +89,7 @@ xapi-idl.storage.interface xapi-idl.xen xapi_internal + xapi_internal_server xapi-test-utils xapi-tracing xapi-types diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 301ea77ccbd..2d9d812a0d9 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -58,7 +58,7 @@ (name xapi_internal) (wrapped false) (modes best) - (modules (:standard \ xapi_main)) + (modules (:standard \ xapi_main server api_server xapi)) (libraries angstrom astring @@ -171,6 +171,41 @@ System_domains Xapi_psr Xapi_services Xapi_udhcpd))) ) +(library + (name xapi_internal_server) + (modes best) + (wrapped false) + (modules server 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-idl + xapi-inventory + 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 (modes exe) (name xapi_main) @@ -179,6 +214,7 @@ (modules xapi_main) (libraries xapi_internal + xapi_internal_server xapi-idl xapi-log xapi-stdext-unix From bc1a58c2f899a241696daf2389c23269ee1c8331 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 35/52] [maintenance]: remove API.API MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This signature is completely unused. We could instead generate a client.mli, but that is more complicated, currently the client.mli it'd generate wouldn't be polymorphic enough. Signed-off-by: Edwin Török --- ocaml/idl/ocaml_backend/gen_api.ml | 1 - 1 file changed, 1 deletion(-) 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) ] ) From 3f6228bd062fcc75e1575d3e104da446253cfe1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 36/52] [maintenance]: remove dependency between most tests and server.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Server.ml takes a while to compile, but most unit tests don't actually need it. Reorganize Api_server into Api_server+Api_server_common, where the latter suffices for unit tests. 'dune runtest' times are improved: ``` hyperfine --min-runs 2 'dune clean; dune runtest --cache=disabled' 'cd ../scm-prev; dune clean; dune runtest --cache=disabled' Benchmark 1: dune clean; dune runtest --cache=disabled Time (mean ± σ): 103.491 s ± 1.596 s [User: 374.464 s, System: 125.957 s] Range (min … max): 102.363 s … 104.620 s 2 runs Benchmark 2: cd ../scm-prev; dune clean; dune runtest --cache=disabled Time (mean ± σ): 114.158 s ± 2.980 s [User: 380.638 s, System: 134.558 s] Range (min … max): 112.051 s … 116.266 s 2 runs Summary dune clean; dune runtest --cache=disabled ran 1.10 ± 0.03 times faster than cd ../scm-prev; dune clean; dune runtest --cache=disabled ``` Signed-off-by: Edwin Török --- ocaml/tests/common/dune | 1 - ocaml/tests/common/suite_init.ml | 2 +- ocaml/tests/common/test_common.ml | 21 -- ocaml/tests/dune | 25 ++- ocaml/tests/suite_alcotest.ml | 5 +- ocaml/tests/suite_alcotest_server.ml | 11 ++ ocaml/tests/test_client.ml | 24 ++- ocaml/tests/test_valid_ref_list.ml | 2 +- ocaml/tests/test_vdi_cbt.ml | 2 +- ocaml/tests/test_vm_check_operation_error.ml | 9 +- ocaml/tests/test_vm_group.ml | 4 +- ocaml/xapi/api_server.ml | 195 +------------------ ocaml/xapi/api_server_common.ml | 195 +++++++++++++++++++ ocaml/xapi/message_forwarding.ml | 30 +++ ocaml/xapi/xapi.ml | 31 +-- quality-gate.sh | 2 +- 16 files changed, 294 insertions(+), 265 deletions(-) create mode 100644 ocaml/tests/suite_alcotest_server.ml create mode 100644 ocaml/xapi/api_server_common.ml diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index fff8623dee9..c578f5f9785 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -21,7 +21,6 @@ xapi-idl.network xapi-idl.xen.interface xapi_internal - xapi_internal_server xapi-inventory xapi-log xapi-test-utils 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 81a977cfaa3..207853f7a5d 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -5,8 +5,9 @@ (modules (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_network_sriov + test_client test_valid_ref_list suite_alcotest_server test_vm_placement test_vm_helpers test_repository test_repository_helpers - test_ref + test_ref test_vm_group test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer test_pool_periodic_update_sync test_pkg_mgr)) (libraries @@ -30,7 +31,6 @@ threads.posix uuid xapi-backtrace - xapi-client xapi_cli_server xapi-consts xapi_database @@ -40,7 +40,6 @@ xapi-idl.xen.interface xapi-idl.xen.interface.types xapi_internal - xapi_internal_server xapi-log xapi-stdext-date xapi-stdext-std @@ -58,6 +57,25 @@ ) ) +(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 @@ -89,7 +107,6 @@ xapi-idl.storage.interface xapi-idl.xen xapi_internal - xapi_internal_server xapi-test-utils xapi-tracing xapi-types 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/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/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/xapi.ml b/ocaml/xapi/xapi.ml index 0b1c213e993..26659a55801 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -164,36 +164,7 @@ let register_callback_fns () = Api_server.callback1 false req sock xml in Xapi_cli.rpc_fun := Some fake_rpc ; - let set_stunnelpid _task_opt pid = - Locking_helpers.Thread_state.acquired - (Locking_helpers.Process ("stunnel", pid)) - in - let unset_stunnelpid _task_opt pid = - Locking_helpers.Thread_state.released - (Locking_helpers.Process ("stunnel", pid)) - in - let stunnel_destination_is_ok addr = - Server_helpers.exec_with_new_task "check_stunnel_destination" - (fun __context -> - let hosts = - Db.Host.get_refs_where ~__context - ~expr:(Eq (Field "address", Literal addr)) - in - match hosts with - | [host] -> ( - try - Message_forwarding.check_live ~__context host ; - true - with _ -> false - ) - | _ -> - true - ) - in - Xmlrpc_client.Internal.set_stunnelpid_callback := Some set_stunnelpid ; - Xmlrpc_client.Internal.unset_stunnelpid_callback := Some unset_stunnelpid ; - Xmlrpc_client.Internal.destination_is_ok := Some stunnel_destination_is_ok ; - TaskHelper.init () + Message_forwarding.register_callback_fns () let noevents = ref false diff --git a/quality-gate.sh b/quality-gate.sh index be4e470fc94..f9c644467f5 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=512 + N=513 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From f823835946b9daa310033e71bad412c1fb3cfaf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 22:37:02 +0100 Subject: [PATCH 37/52] [maintenance]: remove unneeded dependencies MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `sexpr` is now fully thread safe without having to use locks, doesn't need to depend on threadext. `gen_api_main` can use the external `uuidm` module directly, without waiting for internal one to be built. `dune-build-info` is only needed by xapi_version. `xapi-stdext-unix` is not needed in `xapi-idl` The sexplib ppx runtime also doesn't need to be linked in some libraries that do not use it anymore, and where it is used it'll be automatically linked. Signed-off-by: Edwin Török --- dune-project | 4 ++-- ocaml/alerts/certificate/dune | 2 +- ocaml/alerts/dune | 2 -- ocaml/database/dune | 11 +++-------- ocaml/db_process/dune | 2 +- ocaml/doc/dune | 4 +--- ocaml/events/dune | 1 - ocaml/gencert/dune | 2 -- ocaml/idl/autogen/dune | 2 +- ocaml/idl/dune | 7 +------ ocaml/idl/json_backend/dune | 3 +-- ocaml/idl/ocaml_backend/dune | 5 +---- ocaml/idl/ocaml_backend/gen_rbac.ml | 2 +- ocaml/libs/clock/dune | 1 - ocaml/libs/http-lib/dune | 6 +++--- ocaml/libs/log/dune | 1 - ocaml/libs/sexpr/dune | 2 -- ocaml/license/dune | 1 - ocaml/mpathalert/dune | 3 +-- ocaml/nbd/src/dune | 2 +- ocaml/networkd/bin/dune | 2 +- ocaml/networkd/bin_db/dune | 2 +- ocaml/networkd/test/dune | 2 +- ocaml/perftest/dune | 2 +- ocaml/quicktest/dune | 2 +- ocaml/rrd2csv/src/dune | 2 +- ocaml/sdk-gen/c/dune | 2 +- ocaml/sdk-gen/csharp/dune | 4 ++-- ocaml/sdk-gen/java/dune | 2 +- ocaml/sdk-gen/powershell/dune | 2 +- ocaml/squeezed/src/dune | 2 +- ocaml/tests/alerts/dune | 2 +- ocaml/tests/dune | 2 +- ocaml/util/dune | 2 +- ocaml/vhd-tool/cli/dune | 2 +- ocaml/vncproxy/dune | 2 +- ocaml/xapi-guard/src/dune | 2 +- ocaml/xapi-guard/test/dune | 2 +- ocaml/xapi-idl/guard/privileged/dune | 2 +- ocaml/xapi-idl/guard/varstored/dune | 2 +- ocaml/xapi-idl/lib/dune | 2 -- ocaml/xapi-idl/network/dune | 2 +- ocaml/xapi-idl/rrd/dune | 2 +- ocaml/xapi-idl/storage/dune | 4 ++-- ocaml/xapi-idl/v6/dune | 2 +- ocaml/xapi-storage-cli/dune | 2 +- ocaml/xapi-storage-script/dune | 2 +- ocaml/xcp-rrdd/bin/rrdd/dune | 4 ++-- ocaml/xcp-rrdd/bin/rrddump/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-dcmi/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-dummy/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-iostat/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-squeezed/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-xenpm/dune | 2 +- ocaml/xcp-rrdd/bin/transport-rw/dune | 2 +- ocaml/xcp-rrdd/test/rrdd/dune | 2 +- ocaml/xcp-rrdd/test/transport/dune | 2 +- ocaml/xe-cli/dune | 2 +- ocaml/xen-api-client/async_examples/dune | 6 ++---- ocaml/xen-api-client/lib_test/dune | 2 +- ocaml/xen-api-client/lwt_examples/dune | 6 +++--- ocaml/xenforeign/dune | 2 +- ocaml/xenopsd/cli/dune | 2 +- ocaml/xenopsd/dbgring/dune | 2 +- ocaml/xenopsd/list_domains/dune | 2 +- ocaml/xenopsd/simulator/dune | 2 +- ocaml/xenopsd/test/dune | 2 +- ocaml/xenopsd/xc/dune | 8 ++++---- ocaml/xsh/dune | 2 +- xapi-rrdd.opam | 1 - xen-api-client.opam | 1 - 71 files changed, 75 insertions(+), 108 deletions(-) diff --git a/dune-project b/dune-project index ad3b41392d1..3c6620b2c6c 100644 --- a/dune-project +++ b/dune-project @@ -67,7 +67,7 @@ (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")) @@ -188,7 +188,7 @@ (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)) diff --git a/ocaml/alerts/certificate/dune b/ocaml/alerts/certificate/dune index e3ef3de0aee..137b23d265e 100644 --- a/ocaml/alerts/certificate/dune +++ b/ocaml/alerts/certificate/dune @@ -20,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/database/dune b/ocaml/database/dune index bdc5cea531a..14ac44931bd 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -9,8 +9,6 @@ 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 @@ -63,7 +61,7 @@ (package xapi) (modules block_device_io) (libraries - dune-build-info + xapi_database xapi-log xapi-stdext-pervasives @@ -77,7 +75,7 @@ (modes exe) (modules database_server_main) (libraries - dune-build-info + http_lib httpsvr threads.posix @@ -93,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 @@ -115,7 +111,6 @@ ) (libraries alcotest - dune-build-info xapi_database xml-light2 ) 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/gencert/dune b/ocaml/gencert/dune index f859078e89a..f83ed49eb51 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -32,7 +32,6 @@ (modules gencert) (libraries astring - dune-build-info gencertlib x509 xapi-inventory @@ -49,7 +48,6 @@ (libraries alcotest cstruct - dune-build-info fmt gencertlib mirage-crypto 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/dune b/ocaml/idl/dune index 0a3aab54c24..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,7 +17,6 @@ xapi-schema xapi-stdext-date xapi-stdext-std - xapi-stdext-unix ) (wrapped false) (preprocess (per_module ((pps ppx_deriving_rpc) Datamodel_types))) @@ -29,7 +27,6 @@ (name datamodel_main) (modules datamodel_main dot_backend dtd_backend markdown_backend) (libraries - dune-build-info mustache xapi-datamodel xapi-stdext-std @@ -53,7 +50,6 @@ (modes exe) (modules schematest) (libraries - dune-build-info rpclib.core rpclib.json xapi_datamodel @@ -67,8 +63,7 @@ (public_name gen_lifecycle) (package xapi-datamodel) (modules gen_lifecycle) - (libraries - dune-build-info + (libraries xapi-datamodel xapi-consts.xapi_version ) diff --git a/ocaml/idl/json_backend/dune b/ocaml/idl/json_backend/dune index 804453c59c1..c03bead0cd8 100644 --- a/ocaml/idl/json_backend/dune +++ b/ocaml/idl/json_backend/dune @@ -1,8 +1,7 @@ (executable (modes exe) (name gen_json) - (libraries - dune-build-info + (libraries fmt xapi-datamodel xapi-consts diff --git a/ocaml/idl/ocaml_backend/dune b/ocaml/idl/ocaml_backend/dune index e373fe33d09..e69b5398959 100644 --- a/ocaml/idl/ocaml_backend/dune +++ b/ocaml/idl/ocaml_backend/dune @@ -3,13 +3,10 @@ (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_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..3c2ab5c67d6 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 diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index ee510d7fc42..1deae570337 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -60,7 +60,7 @@ (modules http_test radix_tree_test) (libraries alcotest - dune-build-info + fmt http_lib ) @@ -97,7 +97,7 @@ (name test_client) (modules test_client) (libraries - dune-build-info + http_lib safe-resources stunnel @@ -112,7 +112,7 @@ (name test_server) (modules test_server) (libraries - dune-build-info + http_lib httpsvr safe-resources diff --git a/ocaml/libs/log/dune b/ocaml/libs/log/dune index fdfd739d082..42e5f664119 100644 --- a/ocaml/libs/log/dune +++ b/ocaml/libs/log/dune @@ -11,7 +11,6 @@ logs threads.posix xapi-backtrace - xapi-stdext-pervasives ) (wrapped false) ) diff --git a/ocaml/libs/sexpr/dune b/ocaml/libs/sexpr/dune index 8f1c2a0e0ef..77653c2abcc 100644 --- a/ocaml/libs/sexpr/dune +++ b/ocaml/libs/sexpr/dune @@ -9,8 +9,6 @@ (modules (:standard \ sexprpp)) (libraries astring - threads.posix - xapi-stdext-threads ) ) diff --git a/ocaml/license/dune b/ocaml/license/dune index 8981c7c0bef..e2ee71b2b3f 100644 --- a/ocaml/license/dune +++ b/ocaml/license/dune @@ -19,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/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/src/dune b/ocaml/nbd/src/dune index 9f242944676..076e6884786 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -4,7 +4,7 @@ (libraries cmdliner consts - dune-build-info + local_xapi_session lwt lwt.unix diff --git a/ocaml/networkd/bin/dune b/ocaml/networkd/bin/dune index 7f154a0db5c..2b50b1e4159 100644 --- a/ocaml/networkd/bin/dune +++ b/ocaml/networkd/bin/dune @@ -16,7 +16,7 @@ (modes exe) (libraries astring - dune-build-info + forkexec http_lib integers diff --git a/ocaml/networkd/bin_db/dune b/ocaml/networkd/bin_db/dune index f36c68215de..b105b554b53 100644 --- a/ocaml/networkd/bin_db/dune +++ b/ocaml/networkd/bin_db/dune @@ -4,7 +4,7 @@ (package xapi-networkd) (modes exe) (libraries - dune-build-info + networklibs xapi-idl.network) ) diff --git a/ocaml/networkd/test/dune b/ocaml/networkd/test/dune index 06c39333171..951eda074a0 100644 --- a/ocaml/networkd/test/dune +++ b/ocaml/networkd/test/dune @@ -4,7 +4,7 @@ (libraries alcotest astring - dune-build-info + fmt networklibs rpclib.core diff --git a/ocaml/perftest/dune b/ocaml/perftest/dune index 137511118b8..eb5bb586d5c 100644 --- a/ocaml/perftest/dune +++ b/ocaml/perftest/dune @@ -4,7 +4,7 @@ (public_name perftest) (package xapi) (libraries - dune-build-info + http_lib rpclib.core threads.posix diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index b5d02cc9496..31219a94d94 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -6,7 +6,7 @@ (libraries alcotest astring - dune-build-info + ezxenstore ezxenstore.watch fmt 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/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/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/java/dune b/ocaml/sdk-gen/java/dune index 2588d3ba785..498b3a7bc09 100644 --- a/ocaml/sdk-gen/java/dune +++ b/ocaml/sdk-gen/java/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache str xapi-datamodel diff --git a/ocaml/sdk-gen/powershell/dune b/ocaml/sdk-gen/powershell/dune index b0f1fe83a4b..39b2f99b75f 100644 --- a/ocaml/sdk-gen/powershell/dune +++ b/ocaml/sdk-gen/powershell/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-datamodel ) diff --git a/ocaml/squeezed/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/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/dune b/ocaml/tests/dune index 207853f7a5d..7cc177ba586 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -15,7 +15,7 @@ angstrom astring cstruct - dune-build-info + fmt http_lib httpsvr 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/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/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/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/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 29ea321bce3..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 diff --git a/ocaml/xapi-idl/network/dune b/ocaml/xapi-idl/network/dune index eb321c114e3..a9a4869945d 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -21,7 +21,7 @@ (modules network_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/rrd/dune b/ocaml/xapi-idl/rrd/dune index 7a407a77e9d..9462c9341e6 100644 --- a/ocaml/xapi-idl/rrd/dune +++ b/ocaml/xapi-idl/rrd/dune @@ -50,7 +50,7 @@ (modes exe) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/storage/dune b/ocaml/xapi-idl/storage/dune index 500a6f5bbfd..05f146429bc 100644 --- a/ocaml/xapi-idl/storage/dune +++ b/ocaml/xapi-idl/storage/dune @@ -54,7 +54,7 @@ (libraries alcotest cmdliner - dune-build-info + xapi-idl xapi-idl.storage xapi-idl.storage.interface @@ -67,7 +67,7 @@ (modules suite vdi_automaton_test) (libraries alcotest - dune-build-info + xapi-idl.storage.interface xapi-idl.storage.interface.types ) diff --git a/ocaml/xapi-idl/v6/dune b/ocaml/xapi-idl/v6/dune index 059bf6fc181..79751c08794 100644 --- a/ocaml/xapi-idl/v6/dune +++ b/ocaml/xapi-idl/v6/dune @@ -19,7 +19,7 @@ (modules v6_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-storage-cli/dune b/ocaml/xapi-storage-cli/dune index d64138c29df..624f2f727e1 100644 --- a/ocaml/xapi-storage-cli/dune +++ b/ocaml/xapi-storage-cli/dune @@ -1,7 +1,7 @@ (executable (name main) (libraries - dune-build-info + xapi-idl xapi-idl.storage xapi-idl.storage.interface diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index c137849c72e..e27762a2963 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -10,7 +10,7 @@ core core_unix core_unix.time_unix - dune-build-info + message-switch-async message-switch-unix result diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index d1a38196462..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 @@ -43,7 +43,7 @@ (modules xcp_rrdd) (libraries astring - dune-build-info + ezxenstore.core ezxenstore.watch forkexec 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 92c674df715..bf654c0e66f 100644 --- a/ocaml/xcp-rrdd/test/rrdd/dune +++ b/ocaml/xcp-rrdd/test/rrdd/dune @@ -4,7 +4,7 @@ (package xapi-rrdd) (libraries alcotest - dune-build-info + fmt rrdd_libs_internal xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/test/transport/dune b/ocaml/xcp-rrdd/test/transport/dune index 333b4db49ce..4efd2bc042d 100644 --- a/ocaml/xcp-rrdd/test/transport/dune +++ b/ocaml/xcp-rrdd/test/transport/dune @@ -3,7 +3,7 @@ (package rrd-transport) (libraries alcotest - dune-build-info + fmt rrd-transport xapi-idl.rrd diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index f72cacbbda4..5362781b31a 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -5,7 +5,7 @@ (package xe) (libraries astring - dune-build-info + fpath safe-resources stunnel diff --git a/ocaml/xen-api-client/async_examples/dune b/ocaml/xen-api-client/async_examples/dune index 7cfce054d69..7d39e42c902 100644 --- a/ocaml/xen-api-client/async_examples/dune +++ b/ocaml/xen-api-client/async_examples/dune @@ -9,7 +9,7 @@ base.caml core core_kernel - dune-build-info + xapi-consts xapi-types xen-api-client @@ -27,9 +27,7 @@ base base.caml core - core_kernel - dune-build-info - ppx_sexp_conv.runtime-lib + core_kernel rpclib.json sexplib0 xapi-consts diff --git a/ocaml/xen-api-client/lib_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/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 d8482fced6e..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 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/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 e795d7295bf..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 diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index c1727b4493e..4a79452dbbe 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -71,7 +71,7 @@ (modules xenops_xc_main) (libraries - dune-build-info + ezxenstore.core uuid xapi-idl @@ -92,7 +92,7 @@ (libraries astring cmdliner - dune-build-info + ezxenstore.core uuid xapi-idl.memory @@ -109,7 +109,7 @@ (modes exe) (modules memory_summary) (libraries - dune-build-info + xapi-stdext-date xapi-stdext-unix xapi-xenopsd @@ -134,7 +134,7 @@ (modules cancel_utils_test) (libraries cmdliner - dune-build-info + ezxenstore.core threads.posix xapi-idl.xen.interface 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/xapi-rrdd.opam b/xapi-rrdd.opam index 8ec47c8322d..745af249f4b 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.opam @@ -11,7 +11,6 @@ bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.15"} "ocaml" {>= "4.02.0"} - "dune-build-info" "alcotest" {with-test} "astring" "gzip" {= version} diff --git a/xen-api-client.opam b/xen-api-client.opam index c9fa73d8cf6..75773851324 100644 --- a/xen-api-client.opam +++ b/xen-api-client.opam @@ -16,7 +16,6 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.15"} - "dune-build-info" "alcotest" {with-test} "astring" "cohttp" {>= "0.22.0"} From ebbc4c6b486f05ea18289dd27865851ad3b4644d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 22:59:43 +0100 Subject: [PATCH 38/52] [maintenance]: break dependency of gen_api_main on xapi_version MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Xapi_version depends on Build_info which can change on every commit. It is better to remove it from the dependencies of gen_api_main, especially that gen_api_main is on the critical path for discovering more dependencies. The 'xapi_user_agent' constant got moved to Xapi_version. Signed-off-by: Edwin Török --- ocaml/util/xapi_version.ml | 6 ++++++ ocaml/util/xapi_version.mli | 2 ++ ocaml/xapi-cli-server/cli_operations.ml | 2 +- ocaml/xapi-cli-server/dune | 1 + ocaml/xapi-consts/constants.ml | 8 -------- ocaml/xapi-consts/dune | 4 ---- ocaml/xapi/create_misc.ml | 3 ++- ocaml/xapi/dune | 1 + ocaml/xapi/export.ml | 4 ++-- ocaml/xapi/importexport.ml | 8 ++++---- ocaml/xapi/system_status.ml | 2 +- ocaml/xapi/xapi_http.ml | 4 ++-- ocaml/xapi/xapi_pool.ml | 4 ++-- 13 files changed, 24 insertions(+), 25 deletions(-) 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/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/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/dune b/ocaml/xapi/dune index 2d9d812a0d9..d979250bda5 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -154,6 +154,7 @@ xapi-stdext-zerocheck xapi-tracing xapi-tracing-export + xapi_version xapi-xenopsd xenstore_transport.unix xml-light2 diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 6cb156d21ca..24589827bc8 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -829,7 +829,7 @@ let metadata_handler (req : Request.t) s _ = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ Http.Hdr.task_id ^ ": " ^ task_id - ; "Server: " ^ Constants.xapi_user_agent + ; "Server: " ^ Xapi_version.xapi_user_agent ; content_type ; "Content-Length: " ^ string_of_int content_length ; "Content-Disposition: attachment; filename=\"export.xva\"" @@ -944,7 +944,7 @@ let handler (req : Request.t) s _ = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ Http.Hdr.task_id ^ ": " ^ task_id - ; "Server: " ^ Constants.xapi_user_agent + ; "Server: " ^ Xapi_version.xapi_user_agent ; content_type ; "Content-Disposition: attachment; filename=\"export.xva\"" ] diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index 869aac2a5f0..b6f784dc55c 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -41,8 +41,8 @@ let rpc_of_version x = ; (_product_version, Rpc.String x.product_version) ; (_product_brand, Rpc.String x.product_brand) ; (_build_number, Rpc.String x.build_number) - ; (_xapi_major, Rpc.Int (Int64.of_int Constants.version_major)) - ; (_xapi_minor, Rpc.Int (Int64.of_int Constants.version_minor)) + ; (_xapi_major, Rpc.Int (Int64.of_int Xapi_version.xapi_version_major)) + ; (_xapi_minor, Rpc.Int (Int64.of_int Xapi_version.xapi_version_minor)) ; (_export_vsn, Rpc.Int (Int64.of_int Xapi_globs.export_vsn)) ] @@ -112,8 +112,8 @@ let this_version __context = ; product_version= Xapi_version.product_version () ; product_brand= Xapi_version.product_brand () ; build_number= Xapi_version.build_number () - ; xapi_vsn_major= Constants.version_major - ; xapi_vsn_minor= Constants.version_minor + ; xapi_vsn_major= Xapi_version.xapi_version_major + ; xapi_vsn_minor= Xapi_version.xapi_version_minor ; export_vsn= Xapi_globs.export_vsn } diff --git a/ocaml/xapi/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/xapi_http.ml b/ocaml/xapi/xapi_http.ml index 13738ff292a..694520a5609 100644 --- a/ocaml/xapi/xapi_http.ml +++ b/ocaml/xapi/xapi_http.ml @@ -90,7 +90,7 @@ let create_session_for_client_cert req s = (* Has been authenticated. Performing RBAC check only ... *) Xapi_session.login_with_password ~__context ~uname:"" ~pwd:"" ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent | Some `root | None -> raise (Http.Unauthorised "") @@ -300,7 +300,7 @@ let server = let server = Http_svr.Server.empty () in server -let http_request = Http.Request.make ~user_agent:Constants.xapi_user_agent +let http_request = Http.Request.make ~user_agent:Xapi_version.xapi_user_agent let bind inetaddr = let description = diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index c14d2acf806..f0cd7c49bfc 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1427,7 +1427,7 @@ let join_common ~__context ~master_address ~master_username ~master_password Client.Session.login_with_password ~rpc:unverified_rpc ~uname:master_username ~pwd:master_password ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent with Http_client.Http_request_rejected _ | Http_client.Http_error _ -> raise (Api_errors.Server_error @@ -1466,7 +1466,7 @@ let join_common ~__context ~master_address ~master_username ~master_password try Client.Session.login_with_password ~rpc ~uname:master_username ~pwd:master_password ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent with Http_client.Http_request_rejected _ | Http_client.Http_error _ -> raise (Api_errors.Server_error From c8e828e725a5ee869c7d353c1885213016d75878 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 23:07:44 +0100 Subject: [PATCH 39/52] [maintenance]: xapi-types should not depend on xapi-idl MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-types/dune | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml/xapi-types/dune b/ocaml/xapi-types/dune index 12d1703ce3d..3fb8e0711b1 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -21,7 +21,6 @@ xapi-consts xapi-stdext-date xapi-stdext-unix - xapi-idl ) (wrapped false) (preprocess (per_module ((pps ppx_deriving_rpc) API Event_types Features SecretString))) From 9c85ed7dd86fc5bea2e83bf79a3cb23df5d810a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 23:28:49 +0100 Subject: [PATCH 40/52] [maintenance]: use bytecode for gen_api_main MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It'll be slower, but it can run a lot earlier in the build process. Compiling the datamodels takes time, but compiling them for bytecode is faster. Signed-off-by: Edwin Török --- ocaml/idl/ocaml_backend/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/ocaml_backend/dune b/ocaml/idl/ocaml_backend/dune index e69b5398959..f6c4173d363 100644 --- a/ocaml/idl/ocaml_backend/dune +++ b/ocaml/idl/ocaml_backend/dune @@ -1,5 +1,5 @@ (executable - (modes exe) + (modes byte) (name gen_api_main) (libraries astring From bf350976df7eb99d1fddaa457273bfe8011a46fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 23:54:46 +0100 Subject: [PATCH 41/52] [maintenance]: further split xapi_internal_server MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduce a _minimal library, so we can start compiling server.ml earlier. Build time reduced from 80s to: ``` Benchmark 1: dune clean; dune build --cache=disabled Time (mean ± σ): 67.081 s ± 0.190 s [User: 326.847 s, System: 103.668 s Range (min … max): 66.946 s … 67.215 s 2 runs ``` Signed-off-by: Edwin Török --- ocaml/xapi/dune | 55 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 53 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index d979250bda5..1dd7d06911a 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -54,11 +54,50 @@ (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) + (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 server api_server xapi)) + (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 @@ -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 @@ -172,11 +212,19 @@ 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 server api_server xapi) + (modules api_server xapi) (libraries forkexec http_lib @@ -190,8 +238,10 @@ 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 @@ -216,6 +266,7 @@ (libraries xapi_internal xapi_internal_server + xapi_internal_minimal xapi-idl xapi-log xapi-stdext-unix From 62ff5e74065c810d79cc5c6db751b6121646d5bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:35 +0000 Subject: [PATCH 42/52] [maintenance]: reduce basic-rpc-test time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Remove most sleeps, and reduce test duration from 5 seconds to 1. (If we do want to run a performance test we can increase these again) Run just a basic test for 0.1 seconds instead of a performance test for 5s by default. (can still be tweaked by overriding SECS) Signed-off-by: Edwin Török --- .../core_test/basic-rpc-test.sh | 46 ++++++++++--------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/ocaml/message-switch/core_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh index 877790370a2..ce0aea92be3 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=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}" From 7530d5e1ca8d5742990e45c61a01f2ebdbb779a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:35 +0000 Subject: [PATCH 43/52] [maintenance]: try to reconnect to message-switch every 0.5s MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Instead of every 5s. Speeds up testing, and may speed up startup somewhat. And a connection try once every 0.5s won't create a lot of load on the system. (If needed we could implement some form of exponential backoff here). ``` Benchmark 1: dune clean; dune runtest --cache=disabled Time (mean ± σ): 97.642 s ± 0.933 s [User: 354.132 s, System: 113.436 s] Range (min … max): 96.982 s … 98.302 s 2 runsi ``` Signed-off-by: Edwin Török --- ocaml/message-switch/async/protocol_async.ml | 2 +- ocaml/message-switch/core_test/basic-rpc-test.sh | 2 +- ocaml/message-switch/lwt/protocol_lwt.ml | 2 +- ocaml/message-switch/unix/protocol_unix.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) 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_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh index ce0aea92be3..bc281c65f45 100755 --- a/ocaml/message-switch/core_test/basic-rpc-test.sh +++ b/ocaml/message-switch/core_test/basic-rpc-test.sh @@ -3,7 +3,7 @@ set -e SPATH=${TMPDIR:-/tmp}/sock_s SWITCHPATH=${TMPDIR:-/tmp}/switch_s -SECS=0.1 +SECS=${SECS:-0.1} rm -rf "${SWITCHPATH}" && mkdir -p "${SWITCHPATH}" 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/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 ; From a6406eaab37e0d4fd2aafa814677a0ba56959e6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 24 Jul 2024 09:39:41 +0100 Subject: [PATCH 44/52] [maintenance]: add back the 5s message-switch test as a stresstest MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/message-switch/core_test/dune | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) 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 From e5fa761d7516c58bb5b1324a9956182c64b41a80 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 24 Jul 2024 11:31:18 +0100 Subject: [PATCH 45/52] maintenance: delete unused fields These are errors in dune 3.15 and don't seem to be problematic Signed-off-by: Pau Ruiz Safont --- ocaml/database/master_connection.ml | 2 +- ocaml/idl/datamodel_values.ml | 2 +- ocaml/libs/http-lib/buf_io.ml | 7 +------ ocaml/libs/http-lib/xmlrpc_client.ml | 2 +- ocaml/libs/stunnel/stunnel_cache.ml | 20 +++++-------------- ocaml/libs/stunnel/stunnel_cache.mli | 3 +-- ocaml/libs/vhd/vhd_format/f.ml | 4 ---- ocaml/libs/vhd/vhd_format_lwt/block.ml | 5 ++--- ocaml/libs/vhd/vhd_format_lwt/iO.ml | 4 ++-- .../lib/xapi-stdext-threads/threadext.ml | 8 ++------ .../lib/xapi-stdext-unix/unixext.ml | 2 +- ocaml/libs/xml-light2/xml.ml | 6 +++--- ocaml/message-switch/switch/logging.ml | 9 +-------- ocaml/rrd2csv/src/rrd2csv.ml | 12 +++-------- ocaml/xapi-idl/lib/scheduler.ml | 4 ++-- ocaml/xapi-idl/lib/task_server.ml | 4 +--- ocaml/xapi/vgpuops.ml | 4 ---- ocaml/xapi/xapi_dr_task.ml | 9 +-------- ocaml/xapi/xapi_event.ml | 18 ++++++----------- ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml | 9 ++++----- ocaml/xen-api-client/lib_test/xen_api_test.ml | 10 +++++----- ocaml/xsh/xsh.ml | 2 +- 22 files changed, 44 insertions(+), 102 deletions(-) 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/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/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/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/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index 36d986b89c3..d69fbf10091 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -37,11 +37,7 @@ let ignore_log fmt = Printf.ksprintf (fun _ -> ()) fmt (* Use and overlay the definition from D. *) let debug = if debug_enabled then debug else ignore_log -type endpoint = { - host: string - ; port: int - ; verified: Stunnel.verification_config option -} +type endpoint = {host: string; port: int} (* Need to limit the absolute number of stunnels as well as the maximum age *) let max_stunnel = 70 @@ -187,13 +183,7 @@ let add (x : Stunnel.t) = incr counter ; Hashtbl.add !times idx now ; Tbl.move_into !stunnels idx x ; - let ep = - { - host= x.Stunnel.host - ; port= x.Stunnel.port - ; verified= x.Stunnel.verified - } - in + let ep = {host= x.Stunnel.host; port= x.Stunnel.port} in let existing = Option.value (Hashtbl.find_opt !index ep) ~default:[] in Hashtbl.replace !index ep (idx :: existing) ; debug "Adding stunnel id %s (idle %.2f) to the cache" (id_of_stunnel x) 0. ; @@ -203,8 +193,8 @@ let add (x : Stunnel.t) = (** Returns an Stunnel.t for this endpoint (oldest first), raising Not_found if none can be found. First performs a garbage-collection, which discards expired stunnels if needed. *) -let with_remove ~host ~port verified f = - let ep = {host; port; verified} in +let with_remove ~host ~port f = + let ep = {host; port} in let get_id () = with_lock m (fun () -> unlocked_gc () ; @@ -253,7 +243,7 @@ let flush () = let with_connect ?use_fork_exec_helper ?write_to_log ~verify_cert ~host ~port f = - match with_remove ~host ~port verify_cert f with + match with_remove ~host ~port f with | Some r -> r | None -> diff --git a/ocaml/libs/stunnel/stunnel_cache.mli b/ocaml/libs/stunnel/stunnel_cache.mli index 00f4ce9df62..9a2923dfcbf 100644 --- a/ocaml/libs/stunnel/stunnel_cache.mli +++ b/ocaml/libs/stunnel/stunnel_cache.mli @@ -28,7 +28,7 @@ val with_connect : -> (Stunnel.t -> 'b) -> 'b (** Connects via stunnel (optionally via an external 'fork/exec helper') to - a host and port. If there is a suitable stunnel in the cache then this + a host and port. If there is a suitable stunnel in the cache then this will be used, otherwise we make a fresh one. *) val add : Stunnel.t -> unit @@ -37,7 +37,6 @@ val add : Stunnel.t -> unit val with_remove : host:string (** host *) -> port:int (** port *) - -> Stunnel.verification_config option -> (Stunnel.t -> 'b) -> 'b option (** Given a host and port call a function with a cached stunnel, or return None. *) diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index a361a4fde3a..6109c8aa713 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -1607,8 +1607,6 @@ module Vhd = struct module Field = struct (** Dynamically-typed field-level access *) - type 'a f = {name: string; get: 'a t -> string} - let _features = "features" let _data_offset = "data-offset" @@ -1770,8 +1768,6 @@ module Vhd = struct opt (fun (t, _) -> Int32.to_string t.Batmap_header.checksum) t.batmap else None - - type 'a t = 'a f end end diff --git a/ocaml/libs/vhd/vhd_format_lwt/block.ml b/ocaml/libs/vhd/vhd_format_lwt/block.ml index 1ab35d33585..b4574e14e28 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/block.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/block.ml @@ -25,7 +25,7 @@ let pp_write_error = Mirage_block.pp_write_error type info = Mirage_block.info -type t = {mutable vhd: IO.fd Vhd_format.F.Vhd.t option; info: info; id: string} +type t = {mutable vhd: IO.fd Vhd_format.F.Vhd.t option; info: info} let connect path = Lwt_unix.LargeFile.stat path >>= fun _ -> @@ -38,8 +38,7 @@ let connect path = let sector_size = 512 in let size_sectors = Int64.div vhd.Vhd.footer.Footer.current_size 512L in let info = Mirage_block.{read_write; sector_size; size_sectors} in - let id = path in - return {vhd= Some vhd; info; id} + return {vhd= Some vhd; info} let disconnect t = match t.vhd with diff --git a/ocaml/libs/vhd/vhd_format_lwt/iO.ml b/ocaml/libs/vhd/vhd_format_lwt/iO.ml index 0940e6c56c3..d2768374795 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/iO.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/iO.ml @@ -46,13 +46,13 @@ let complete name offset op fd buffer = module Fd = struct open Lwt - type fd = {fd: Lwt_unix.file_descr; filename: string; lock: Lwt_mutex.t} + type fd = {fd: Lwt_unix.file_descr; lock: Lwt_mutex.t} let openfile filename rw = let unix_fd = File.openfile filename rw 0o644 in let fd = Lwt_unix.of_unix_file_descr unix_fd in let lock = Lwt_mutex.create () in - return {fd; filename; lock} + return {fd; lock} let fsync {fd; _} = let fd' = Lwt_unix.unix_file_descr fd in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index ef30cfb5ba4..b255239dd4d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -49,15 +49,13 @@ module Delay = struct (* Concrete type is the ends of a pipe *) type t = { (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option - ; mutable pipe_in: Unix.file_descr option + mutable pipe_in: Unix.file_descr option ; (* Indicates that a signal arrived before a wait: *) mutable signalled: bool ; m: M.t } - let make () = - {pipe_out= None; pipe_in= None; signalled= false; m= M.create ()} + let make () = {pipe_in= None; signalled= false; m= M.create ()} exception Pre_signalled @@ -80,7 +78,6 @@ module Delay = struct let pipe_out, pipe_in = Unix.pipe () in (* these will be unconditionally closed on exit *) to_close := [pipe_out; pipe_in] ; - x.pipe_out <- Some pipe_out ; x.pipe_in <- Some pipe_in ; x.signalled <- false ; pipe_out @@ -99,7 +96,6 @@ module Delay = struct ) (fun () -> Mutex.execute x.m (fun () -> - x.pipe_out <- None ; x.pipe_in <- None ; List.iter close' !to_close ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/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/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/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/xapi-idl/lib/scheduler.ml b/ocaml/xapi-idl/lib/scheduler.ml index d4d5c7c5cca..e46a0fdbd29 100644 --- a/ocaml/xapi-idl/lib/scheduler.ml +++ b/ocaml/xapi-idl/lib/scheduler.ml @@ -41,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 @@ -88,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/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_dr_task.ml b/ocaml/xapi/xapi_dr_task.ml index 631c7ee4916..6766775a5f1 100644 --- a/ocaml/xapi/xapi_dr_task.ml +++ b/ocaml/xapi/xapi_dr_task.ml @@ -26,12 +26,7 @@ let make_task ~__context = ref (* A type to represent an SR record parsed from an sr_probe result. *) -type sr_probe_sr = { - uuid: string - ; name_label: string - ; name_description: string - ; metadata_detected: bool -} +type sr_probe_sr = {uuid: string; name_label: string; name_description: string} (* Attempt to parse a key/value pair from XML. *) let parse_kv = function @@ -53,8 +48,6 @@ let parse_sr_probe xml = uuid= List.assoc "UUID" all ; name_label= List.assoc "name_label" all ; name_description= List.assoc "name_description" all - ; metadata_detected= - List.assoc "pool_metadata_detected" all = "true" } | _ -> failwith "Malformed or missing " diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index b56e4199779..8c7432106ab 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -117,17 +117,12 @@ module Next = struct let highest_forgotten_id = ref (-1L) type subscription = { - mutable last_id: int64 - ; (* last event ID to sent to this client *) - mutable subs: Subscription.t list - ; (* list of all the subscriptions *) - m: Mutex.t - ; (* protects access to the mutable fields in this record *) - session: API.ref_session - ; (* session which owns this subscription *) - mutable session_invalid: bool - ; (* set to true if the associated session has been deleted *) - mutable timeout: float (* Timeout *) + mutable last_id: int64 (** last event ID to sent to this client *) + ; mutable subs: Subscription.t list (** all the subscriptions *) + ; m: Mutex.t (** protects access to the mutable fields in this record *) + ; session: API.ref_session (** session which owns this subscription *) + ; mutable session_invalid: bool + (** set to true if the associated session has been deleted *) } (* For Event.next, the single subscription associated with a session *) @@ -235,7 +230,6 @@ module Next = struct ; m= Mutex.create () ; session ; session_invalid= false - ; timeout= 0.0 } in Hashtbl.replace subscriptions session subscription ; diff --git a/ocaml/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/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/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 } From 9fd09c87f908441039e1f25ccef5461fe3670758 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 24 Jul 2024 17:42:48 +0100 Subject: [PATCH 46/52] datamodel_lifecycle: automated bump Signed-off-by: Pau Ruiz Safont --- ocaml/idl/datamodel_lifecycle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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" -> From cd16298c3b2cc1ffbd9b6265f2ba9783c8a96732 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 25 Jul 2024 10:10:39 +0100 Subject: [PATCH 47/52] maintenance: restore dune utop Signed-off-by: Pau Ruiz Safont --- ocaml/sdk-gen/go/dune | 1 + ocaml/xapi/dune | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) 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/xapi/dune b/ocaml/xapi/dune index 1dd7d06911a..564022ec6bb 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -57,6 +57,7 @@ (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 @@ -65,7 +66,7 @@ xapi-types xapi_database mtime - tracing + tracing uuid rpclib.core threads.posix From e2c0ac646aac0507579ad141ec2bb6c09b21a59c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 5 Jul 2024 14:36:42 +0100 Subject: [PATCH 48/52] xapi: update mirage-crypto version Also make dune generate the opam metadata Signed-off-by: Pau Ruiz Safont --- dune-project | 62 ++++++++++++++++++++++ ocaml/gencert/dune | 2 + ocaml/gencert/lib.ml | 2 +- ocaml/gencert/selfcert.ml | 2 +- ocaml/gencert/test_lib.ml | 2 +- ocaml/xapi/certificates.ml | 2 +- ocaml/xapi/dune | 1 + xapi.opam | 102 ++++++++++++++++++++----------------- xapi.opam.template | 79 ---------------------------- 9 files changed, 123 insertions(+), 131 deletions(-) diff --git a/dune-project b/dune-project index 3c6620b2c6c..780c227a986 100644 --- a/dune-project +++ b/dune-project @@ -301,6 +301,68 @@ (package (name xapi) + (synopsis "The toolstack daemon which implements the XenAPI") + (description "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.") + (depends + alcotest ; needed for the quicktest binary + angstrom + base-threads + base64 + cdrom + conf-pam + (crowbar :with-test) + ctypes + ctypes-foreign + domain-name + (ezxenstore (= :version)) + (fmt :with-test) + hex + (http-lib (and :with-test (= :version))) ; the public library is only used for testing + ipaddr + mirage-crypto + mirage-crypto-pk + (mirage-crypto-rng (>= "0.11.0")) + (message-switch-unix (= :version)) + mtime + opentelemetry-client-ocurl + pci + (pciutil (= :version)) + ppx_deriving_rpc + ppx_sexp_conv + ppx_deriving + psq + rpclib + (rrdd-plugin (= :version)) + rresult + sexpr + sha + (stunnel (= :version)) + tar + tar-unix + (uuid (= :version)) + x509 + (xapi-client (= :version)) + (xapi-cli-protocol (= :version)) + (xapi-consts (= :version)) + (xapi-datamodel (= :version)) + (xapi-expiry-alerts (= :version)) + (xapi-idl (= :version)) + (xapi-inventory (= :version)) + (xapi-log (= :version)) + (xapi-stdext-date (= :version)) + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std (= :version)) + (xapi-stdext-threads (= :version)) + (xapi-stdext-unix (= :version)) + (xapi-stdext-zerocheck (= :version)) + (xapi-test-utils :with-test) + (xapi-tracing (= :version)) + (xapi-types (= :version)) + (xapi-xenopsd (= :version)) + (xml-light2 (= :version)) + yojson + (zstd (= :version)) + ) ) (package diff --git a/ocaml/gencert/dune b/ocaml/gencert/dune index f83ed49eb51..ef7875abd29 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -10,6 +10,7 @@ forkexec mirage-crypto mirage-crypto-pk + mirage-crypto-rng mirage-crypto-rng.unix ptime ptime.clock.os @@ -52,6 +53,7 @@ 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..d4903924276 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -19,7 +19,7 @@ open Rresult type t_certificate = Leaf | Chain -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let validate_private_key pkcs8_private_key = let ensure_rsa_key_length = function diff --git a/ocaml/gencert/selfcert.ml b/ocaml/gencert/selfcert.ml index 02749493f95..7b961a74ff6 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -43,7 +43,7 @@ let valid_from' date = (** initialize the random number generator at program startup when this module is loaded. *) -let () = Mirage_crypto_rng_unix.initialize () +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 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/xapi/certificates.ml b/ocaml/xapi/certificates.ml index effb154877e..23e8999edc0 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -19,7 +19,7 @@ module D = Debug.Make (struct let name = "certificates" end) open D -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) (* Certificate locations: * a) stunnel external = /etc/xensource/xapi-ssl.pem diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 1dd7d06911a..8494f761817 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -121,6 +121,7 @@ message-switch-core message-switch-unix mirage-crypto + mirage-crypto-rng mirage-crypto-rng.unix mtime mtime.clock.os diff --git a/xapi.opam b/xapi.opam index 387ba542fe6..6f67cf1c1f3 100644 --- a/xapi.opam +++ b/xapi.opam @@ -1,20 +1,18 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "The toolstack daemon which implements the XenAPI" +description: + "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] depends: [ - "ocaml" - "dune" - "alcotest" # needed to generate the quicktest binary + "dune" {>= "3.15"} + "alcotest" "angstrom" + "base-threads" "base64" "cdrom" "conf-pam" @@ -22,56 +20,71 @@ depends: [ "ctypes" "ctypes-foreign" "domain-name" - "ezxenstore" + "ezxenstore" {= version} "fmt" {with-test} "hex" - "http-lib" {with-test} # the public library is only used for testing + "http-lib" {with-test & = version} "ipaddr" - "mirage-crypto" {with-test} + "mirage-crypto" "mirage-crypto-pk" - "mirage-crypto-rng" {with-test} - "message-switch-unix" + "mirage-crypto-rng" {>= "0.11.0"} + "message-switch-unix" {= version} "mtime" "opentelemetry-client-ocurl" "pci" - "pciutil" + "pciutil" {= version} "ppx_deriving_rpc" "ppx_sexp_conv" "ppx_deriving" "psq" "rpclib" - "rrdd-plugin" + "rrdd-plugin" {= version} "rresult" "sexpr" "sha" - "stunnel" + "stunnel" {= version} "tar" "tar-unix" - "base-threads" - "base-unix" - "uuid" + "uuid" {= version} "x509" - "xapi-client" - "xapi-cli-protocol" - "xapi-consts" - "xapi-datamodel" - "xapi-expiry-alerts" - "xapi-stdext-date" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" + "xapi-client" {= version} + "xapi-cli-protocol" {= version} + "xapi-consts" {= version} + "xapi-datamodel" {= version} + "xapi-expiry-alerts" {= version} + "xapi-idl" {= version} + "xapi-inventory" {= version} + "xapi-log" {= version} + "xapi-stdext-date" {= version} + "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} + "xapi-stdext-threads" {= version} + "xapi-stdext-unix" {= version} + "xapi-stdext-zerocheck" {= version} "xapi-test-utils" {with-test} - "xapi-tracing" - "xapi-types" - "xapi-xenopsd" - "xapi-idl" - "xapi-inventory" - "xml-light2" + "xapi-tracing" {= version} + "xapi-types" {= version} + "xapi-xenopsd" {= version} + "xml-light2" {= version} "yojson" - "zstd" + "zstd" {= version} + "odoc" {with-doc} ] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} @@ -79,10 +92,3 @@ depexts: [ ["hwdata" "xxhash-devel" "xxhash-libs"] {os-distribution = "fedora"} ["hwdata" "xxhash-dev" "xxhash"] {os-distribution = "alpine"} ] -synopsis: "The xapi toolstack daemon which implements the XenAPI" -description: """ -This daemon exposes the XenAPI and is used by clients such as 'xe' -and 'XenCenter' to manage clusters of Xen-enabled hosts.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/xapi.opam.template b/xapi.opam.template index 49f3902f66a..3dea8527e92 100644 --- a/xapi.opam.template +++ b/xapi.opam.template @@ -1,75 +1,3 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "ocaml" - "dune" - "alcotest" # needed to generate the quicktest binary - "angstrom" - "base64" - "cdrom" - "conf-pam" - "crowbar" {with-test} - "ctypes" - "ctypes-foreign" - "domain-name" - "ezxenstore" - "fmt" {with-test} - "hex" - "http-lib" {with-test} # the public library is only used for testing - "ipaddr" - "mirage-crypto" {with-test} - "mirage-crypto-pk" - "mirage-crypto-rng" {with-test} - "message-switch-unix" - "mtime" - "opentelemetry-client-ocurl" - "pci" - "pciutil" - "ppx_deriving_rpc" - "ppx_sexp_conv" - "ppx_deriving" - "psq" - "rpclib" - "rrdd-plugin" - "rresult" - "sexpr" - "sha" - "stunnel" - "tar" - "tar-unix" - "base-threads" - "base-unix" - "uuid" - "x509" - "xapi-client" - "xapi-cli-protocol" - "xapi-consts" - "xapi-datamodel" - "xapi-expiry-alerts" - "xapi-stdext-date" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" - "xapi-test-utils" {with-test} - "xapi-tracing" - "xapi-types" - "xapi-xenopsd" - "xapi-idl" - "xapi-inventory" - "xml-light2" - "yojson" - "zstd" -] depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} @@ -77,10 +5,3 @@ depexts: [ ["hwdata" "xxhash-devel" "xxhash-libs"] {os-distribution = "fedora"} ["hwdata" "xxhash-dev" "xxhash"] {os-distribution = "alpine"} ] -synopsis: "The xapi toolstack daemon which implements the XenAPI" -description: """ -This daemon exposes the XenAPI and is used by clients such as 'xe' -and 'XenCenter' to manage clusters of Xen-enabled hosts.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} From 34ee1ef5f5fb6296db84aafb217763fde40441d7 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 23 Jul 2024 15:52:43 +0100 Subject: [PATCH 49/52] mirage-rng: Initialize it only in tests and selfcert Only tests need it to generate crypto keys, but it's needed to create the serial when signing certificates. Signed-off-by: Pau Ruiz Safont --- dune-project | 2 -- ocaml/gencert/lib.ml | 2 -- ocaml/gencert/selfcert.ml | 6 +++--- ocaml/xapi/certificates.ml | 2 -- ocaml/xapi/dune | 2 -- 5 files changed, 3 insertions(+), 11 deletions(-) diff --git a/dune-project b/dune-project index 780c227a986..0e47e350ba1 100644 --- a/dune-project +++ b/dune-project @@ -67,7 +67,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 - (alcotest :with-test) astring (cohttp (>= "0.22.0")) @@ -188,7 +187,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")) - (alcotest :with-test) astring (gzip (= :version)) diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index d4903924276..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 (module Mirage_crypto_rng.Fortuna) - 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 7b961a74ff6..3b022bcb19f 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -41,8 +41,8 @@ let valid_from' date = | None, false -> Ptime_clock.now () -(** initialize the random number generator at program startup when this -module is loaded. *) +(* 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 @@ -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/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 23e8999edc0..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 (module Mirage_crypto_rng.Fortuna) - (* 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/dune b/ocaml/xapi/dune index 8494f761817..371718d3ed8 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -121,8 +121,6 @@ message-switch-core message-switch-unix mirage-crypto - mirage-crypto-rng - mirage-crypto-rng.unix mtime mtime.clock.os pam From f4b9bcf6bbaef8d591e2a4f9cda422f3fa86aab8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 26 Jul 2024 09:16:34 +0100 Subject: [PATCH 50/52] clock: use external qcheck-alcotest Signed-off-by: Pau Ruiz Safont --- clock.opam | 2 + dune-project | 2 + ocaml/libs/clock/dune | 12 +++++- ocaml/libs/clock/test_timer.ml | 76 ---------------------------------- quality-gate.sh | 2 +- 5 files changed, 16 insertions(+), 78 deletions(-) diff --git a/clock.opam b/clock.opam index 52cc8d0ef09..45b4fd162c2 100644 --- a/clock.opam +++ b/clock.opam @@ -13,6 +13,8 @@ depends: [ "astring" "mtime" "ptime" + "qcheck-core" {with-test} + "qcheck-alcotest" {with-test} "odoc" {with-doc} ] build: [ diff --git a/dune-project b/dune-project index 0e47e350ba1..20a8079ca44 100644 --- a/dune-project +++ b/dune-project @@ -29,6 +29,8 @@ astring mtime ptime + (qcheck-core :with-test) + (qcheck-alcotest :with-test) ) ) diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 3c2ab5c67d6..ebc174c9f2e 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -15,5 +15,15 @@ (names test_date test_timer) (package clock) (modules test_date test_timer) - (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-core.runner) + (libraries + alcotest + clock + fmt + mtime + mtime.clock.os + ptime + qcheck-alcotest + qcheck-core + qcheck-core.runner + ) ) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml index 2d5e20d7d8a..fca152ee96d 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))) diff --git a/quality-gate.sh b/quality-gate.sh index f9c644467f5..8f761718627 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -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." From eb58c7dabac9ca61ade57a508555184dd37e9ed7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 25 Jul 2024 18:22:22 +0100 Subject: [PATCH 51/52] CP-50448: move quickcheck tests into internal libraries MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We want to run these from 'quicktest', so make them available as libraries, and add a _run.ml that would run them separately, just as before. (running separately in the CI is better, because it can be parallelize) No functional change. Signed-off-by: Edwin Török --- ocaml/libs/clock/dune | 16 ++++++++++------ ocaml/libs/clock/test_timer.ml | 4 +--- ocaml/libs/clock/test_timer.mli | 3 +++ ocaml/libs/clock/test_timer_run.ml | 4 ++++ ocaml/libs/clock/test_timer_run.mli | 0 ocaml/libs/http-lib/bufio_test.ml | 4 +++- ocaml/libs/http-lib/bufio_test.mli | 1 + ocaml/libs/http-lib/bufio_test_run.ml | 1 + ocaml/libs/http-lib/bufio_test_run.mli | 0 ocaml/libs/http-lib/dune | 19 ++++++++++++++----- .../lib/xapi-stdext-unix/test/dune | 12 +++++++++--- .../lib/xapi-stdext-unix/test/unixext_test.ml | 3 +-- .../xapi-stdext-unix/test/unixext_test.mli | 1 + .../xapi-stdext-unix/test/unixext_test_run.ml | 1 + .../test/unixext_test_run.mli | 0 15 files changed, 49 insertions(+), 20 deletions(-) create mode 100644 ocaml/libs/clock/test_timer_run.ml create mode 100644 ocaml/libs/clock/test_timer_run.mli create mode 100644 ocaml/libs/http-lib/bufio_test_run.ml create mode 100644 ocaml/libs/http-lib/bufio_test_run.mli create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index ebc174c9f2e..67fbef3208f 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -11,19 +11,23 @@ ) ) -(tests - (names test_date test_timer) +(library + (name test_timer) (package clock) - (modules test_date test_timer) + (modules test_timer) (libraries alcotest clock fmt - mtime mtime.clock.os - ptime qcheck-alcotest qcheck-core - qcheck-core.runner ) ) + +(tests + (names test_date test_timer_run) + (package clock) + (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 fca152ee96d..3729826cfa3 100644 --- a/ocaml/libs/clock/test_timer.ml +++ b/ocaml/libs/clock/test_timer.ml @@ -60,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 @@ -154,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/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 1deae570337..5cc1f8292e0 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -3,7 +3,7 @@ (public_name http-lib) (modes best) (wrapped false) - (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test)) + (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test bufio_test_run)) (preprocess (per_module ((pps ppx_deriving_rpc) Http))) (libraries astring @@ -67,9 +67,21 @@ ) (test - (name bufio_test) + (name bufio_test_run) (package http-lib) (modes (best exe)) + (modules bufio_test_run) + (libraries + qcheck-core.runner + bufio_test + ) + ; use fixed seed to avoid causing random failures in CI and package builds + (action (run %{test} -v -bt --seed 42)) +) + +(library + (name bufio_test) + (modes best) (modules bufio_test) (libraries fmt @@ -79,11 +91,8 @@ rresult http_lib qcheck-core - qcheck-core.runner xapi_fd_test ) - ; use fixed seed to avoid causing random failures in CI and package builds - (action (run %{test} -v -bt --seed 42)) ) (rule diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 407d025a8a8..350db0ee85c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,8 +1,14 @@ -(test +(library (name unixext_test) - (package xapi-stdext-unix) (modules unixext_test) - (libraries xapi_stdext_unix qcheck-core mtime.clock.os qcheck-core.runner fmt xapi_fd_test mtime threads.posix rresult) + (libraries xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) +) + +(test + (name unixext_test_run) + (package xapi-stdext-unix) + (modules unixext_test_run) + (libraries unixext_test qcheck-core.runner) ; use fixed seed to avoid causing random failures in CI and package builds (action (run %{test} -v -bt --seed 42)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index e0f2726f303..656dcc1fe56 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -192,5 +192,4 @@ let tests = [test_proxy; test_time_limited_write; test_time_limited_read] let () = (* avoid SIGPIPE *) let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in - Xapi_stdext_unix.Unixext.test_open 1024 ; - QCheck_base_runner.run_tests_main tests + Xapi_stdext_unix.Unixext.test_open 1024 diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli index e69de29bb2d..a10acd45016 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli @@ -0,0 +1 @@ +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml new file mode 100644 index 00000000000..74c7a62241b --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml @@ -0,0 +1 @@ +let () = QCheck_base_runner.run_tests_main Unixext_test.tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli new file mode 100644 index 00000000000..e69de29bb2d From efcb7af9d9d2abd38281f5ae542857965c24c87b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 25 Jul 2024 18:23:24 +0100 Subject: [PATCH 52/52] CP-50448: run the QuickCheck tests in QuickTest MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Quicktest runs in Dom0, and the existing quickcheck tests run in the CI. Some of these test as much the OCaml code, as its interaction with the system (e.g. behaviour of system calls). So it is better to run these tests both in the CI and in Dom0. We run these in long mode, to explore more randomly generated scenarios. The seed can be controlled with QCHECK_SEED environment variable. Similar to @stresstest it uses a random seed, instead of a fixed seed. Signed-off-by: Edwin Török --- ocaml/quicktest/dune | 4 +++- ocaml/quicktest/quicktest.ml | 10 ++++++++++ ocaml/quicktest/quicktest_args.ml | 3 +++ 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 31219a94d94..c4044a7ebb7 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -6,7 +6,6 @@ (libraries alcotest astring - 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)