From 29bf2302a3756f9e190579982d736056dd4403ce Mon Sep 17 00:00:00 2001 From: lippirk Date: Tue, 20 Oct 2020 15:23:23 +0100 Subject: [PATCH 01/13] CP-35026 optionally include client info in logs Signed-off-by: lippirk (cherry picked from commit 7e6d615526e7e356dee3a2e1baf666ef3997e621) --- lib/debug.ml | 28 ++++++++++++++++++---------- lib/debug.mli | 2 +- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/lib/debug.ml b/lib/debug.ml index 96442986..8d34ced6 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -47,9 +47,15 @@ module ThreadLocalTable = struct IntMap.find_opt id t.tbl end -let names = ThreadLocalTable.make () -let tasks = ThreadLocalTable.make () +type task = { + desc: string + ; client: string option +} + +let tasks: task ThreadLocalTable.t = ThreadLocalTable.make () + +let names: string ThreadLocalTable.t = ThreadLocalTable.make () let gettimestring () = let time = Unix.gettimeofday () in @@ -67,11 +73,13 @@ let escape = Astring.String.Ascii.escape let format include_time brand priority message = let id = get_thread_id () in - let name = - match ThreadLocalTable.find names with Some x -> x | None -> "" - in - let task = - match ThreadLocalTable.find tasks with Some x -> x | None -> "" + let task, name = + (* if the task's client is known, attach it to the task's name *) + let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in + match ThreadLocalTable.find tasks with + | None -> "", name + | Some {desc; client=None} -> desc, name + | Some {desc; client=Some client} -> desc, Printf.sprintf "%s->%s" client name in Printf.sprintf "[%s%5s||%d %s|%s|%s] %s" (if include_time then gettimestring () else "") @@ -201,8 +209,8 @@ let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn _bt = let log_backtrace e bt = log_backtrace_exn e bt -let with_thread_associated task f x = - ThreadLocalTable.add tasks task ; +let with_thread_associated ?client desc f x = + ThreadLocalTable.add tasks {desc; client} ; let result = Backtrace.with_backtraces (fun () -> f x) in ThreadLocalTable.remove tasks ; match result with @@ -212,7 +220,7 @@ let with_thread_associated task f x = (* This function is a top-level exception handler typically used on fresh threads. This is the last chance to do something with the backtrace *) output_log "backtrace" Syslog.Err "error" - (Printf.sprintf "%s failed with exception %s" task + (Printf.sprintf "%s failed with exception %s" desc (Printexc.to_string exn)) ; log_backtrace exn bt ; raise exn diff --git a/lib/debug.mli b/lib/debug.mli index ca224e72..78b17cd5 100644 --- a/lib/debug.mli +++ b/lib/debug.mli @@ -20,7 +20,7 @@ val init_logs : unit -> unit (** {2 Associate a task to the current actions} *) -val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b +val with_thread_associated : ?client:string -> string -> ('a -> 'b) -> 'a -> 'b (** Do an action with a task name associated with the current thread *) (** {2 Associate a name to the current thread} *) From 485a86b4fafae6b6c6ce314f9d8f1a5ee623e1a0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 Nov 2020 22:16:28 +0000 Subject: [PATCH 02/13] CA-347560: Add VM.import_metadata_async This is a variant of `VM.import_metadata` that always queues the operation and returns a task id immediately (like most VM operations). This is useful, once the original (synchronous) function may block for longer periods while other operations on the VM complete. Signed-off-by: Rob Hoes (cherry picked from commit 83de389b98214d283ca73d23255601232fc8ef1c) --- xen/xenops_interface.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index cebe545c..1d7cedc7 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -811,6 +811,13 @@ module XenopsAPI (R : RPC) = struct @-> Param.mk ~name:"metadata" Types.string @-> returning vm_id_p err ) + + let import_metadata_async = + declare "VM.import_metadata_async" [] + (debug_info_p + @-> Param.mk ~name:"metadata" Types.string + @-> returning task_id_p err + ) end module PCI = struct From a7d07ab10a33d9b7ec76ba959ccf3193dfec0d32 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Aug 2020 11:02:36 +0100 Subject: [PATCH 03/13] CP-38064: compatibility with rpclib 7 There were two breaking changes affecting the tests: - Avoiding marshalling integer as i8 requires the addition of the strict flag. - A new function for json-rpc to have calls without responses got added cherry-picked from e719e6eecfa6082207f6a4f65c3c0fa4e634a065 Signed-off-by: Pau Ruiz Safont --- lib_test/idl_test_common.ml | 36 ++++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/lib_test/idl_test_common.ml b/lib_test/idl_test_common.ml index a211d878..9709969b 100644 --- a/lib_test/idl_test_common.ml +++ b/lib_test/idl_test_common.ml @@ -33,15 +33,15 @@ module type CONFIG = sig end module type MARSHALLER = sig - val string_of_call : Rpc.call -> string + val string_of_call : ?strict:bool -> Rpc.call -> string val call_of_string : string -> Rpc.call - val string_of_response : Rpc.response -> string + val string_of_response : ?strict:bool -> Rpc.response -> string val response_of_string : string -> Rpc.response - val to_string : Rpc.t -> string + val to_string : ?strict:bool -> Rpc.t -> string val of_string : string -> Rpc.t end @@ -54,11 +54,13 @@ module TJsonrpc : MARSHALLER = struct (* there is a ?strict parameter, and the signature would not match *) let of_string s = of_string s + let to_string ?(strict : _) t = to_string t + let response_of_string r = response_of_string r - let string_of_call call = string_of_call call + let string_of_call ?(strict : _) call = string_of_call call - let string_of_response response = string_of_response response + let string_of_response ?(strict : _) response = string_of_response response end module TXmlrpc : MARSHALLER = struct @@ -69,6 +71,12 @@ module TXmlrpc : MARSHALLER = struct let response_of_string s = response_of_string s let of_string s = of_string s + + let to_string ?(strict : _) t = to_string t + + let string_of_call ?(strict : _) call = string_of_call call + + let string_of_response ?(strict : _) response = string_of_response response end (** The following module implements test cases that write test RPC requests and @@ -105,7 +113,7 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct open M - let declare name _ ty = + let declare_ response_needed name _ ty = let rec inner : type b. ((string * Rpc.t) list * Rpc.t list) list -> b fn -> unit = fun params -> function @@ -170,8 +178,8 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct | _ -> Rpc.Dict named :: List.rev unnamed in - let call = Rpc.call wire_name args in - call) + let rpccall = if response_needed then Rpc.notif else Rpc.call in + rpccall wire_name args) params in List.iteri @@ -229,6 +237,10 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct , `Quick , test_fn ) :: !tests + + let declare name desc_list ty = declare_ false name desc_list ty + + let declare_notification name desc_list ty = declare_ true name desc_list ty end let get_arg call has_named name is_opt = @@ -315,8 +327,8 @@ module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct | Returning (_, _) -> false - let declare : string -> string list -> 'a fn -> _ res = - fun name _ ty -> + let declare_ : bool -> string -> string list -> 'a fn -> _ res = + fun _notification name _ ty -> ( (* Sanity check: ensure the description has been set before we declare any RPCs *) match !description with @@ -430,4 +442,8 @@ module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct responses in tests := !tests @ request_tests @ response_tests + + let declare name desc_list ty = declare_ false name desc_list ty + + let declare_notification name desc_list ty = declare_ true name desc_list ty end From de557b05783ad9b838499fd1c68114151a42a6f4 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 28 Jan 2022 15:04:55 +0000 Subject: [PATCH 04/13] CA-361220: xenopsd: introduce TASK.destroy_on_finish MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit There are certain tasks that are run asynchronously without anyone waiting for the result (e.g. import_metadata_async). Allow setting a flag on these tasks, so that they are cleaned up when finished (either successfully or not). Needed to avoid space leaks due to an ever growing tasks/updates list. Signed-off-by: Edwin Török --- lib/task_server.ml | 66 ++++++++++++++++++++++++++++------------- lib/task_server.mli | 5 ++++ xen/xenops_interface.ml | 5 ++++ 3 files changed, 56 insertions(+), 20 deletions(-) diff --git a/lib/task_server.ml b/lib/task_server.ml index 531204ce..0e416a1c 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -93,6 +93,7 @@ functor ; test_cancel_at: int option (** index of the cancel point to trigger *) ; mutable backtrace: Backtrace.t (** on error, a backtrace *) ; mutable cancellable: bool + ; mutable destroy_on_finish: bool } and tasks = { @@ -149,26 +150,44 @@ functor ) ; backtrace= Backtrace.empty ; cancellable= true + ; destroy_on_finish= false } in Mutex.execute tasks.m (fun () -> tasks.task_map := SMap.add t.id t !(tasks.task_map)) ; t + (* Remove the task from the id -> task mapping. NB any active thread will + still continue. *) + let destroy task = + let tasks = task.tasks in + Mutex.execute tasks.m (fun () -> + tasks.task_map := SMap.remove task.id !(tasks.task_map) + ) + + let task_finished item = + if item.destroy_on_finish then ( + debug "Auto-destroying task %s" item.id ; + destroy item + ) + (* [run t] executes the task body, updating the fields of [t] *) let run item = - try - let start = Unix.gettimeofday () in - let result = item.f item in - let duration = Unix.gettimeofday () -. start in - item.state <- Interface.Task.Completed {Interface.Task.duration; result} ; - debug "Task %s completed; duration = %.0f" item.id duration - with e -> - Backtrace.is_important e ; - error "Task %s failed; %s" item.id (Printexc.to_string e) ; - item.backtrace <- Backtrace.remove e ; - let e = e |> Interface.marshal_exn in - item.state <- Interface.Task.Failed e + ( try + let start = Unix.gettimeofday () in + let result = item.f item in + let duration = Unix.gettimeofday () -. start in + item.state <- + Interface.Task.Completed {Interface.Task.duration; result} ; + debug "Task %s completed; duration = %.0f" item.id duration + with e -> + Backtrace.is_important e ; + error "Task %s failed; %s" item.id (Printexc.to_string e) ; + item.backtrace <- Backtrace.remove e ; + let e = e |> Interface.marshal_exn in + item.state <- Interface.Task.Failed e + ) ; + task_finished item let find_locked tasks id = try SMap.find id !(tasks.task_map) @@ -219,13 +238,6 @@ functor Mutex.execute tasks.m (fun () -> SMap.bindings !(tasks.task_map) |> List.map snd) - (* Remove the task from the id -> task mapping. NB any active thread will - still continue. *) - let destroy task = - let tasks = task.tasks in - Mutex.execute tasks.m (fun () -> - tasks.task_map := SMap.remove task.id !(tasks.task_map)) - let cancel task = let callbacks = Mutex.execute task.tm (fun () -> @@ -286,5 +298,19 @@ functor (* If task is cancelling, just cancel it before setting it to not cancellable *) check_cancelling_locked task ; - task.cancellable <- false) + task.cancellable <- false + ) + + let destroy_on_finish t = + t.destroy_on_finish <- true ; + let already_finished = + Mutex.execute t.tm @@ fun () -> + t.destroy_on_finish <- true ; + match t.state with + | Interface.Task.Pending _ -> + false + | Interface.Task.Completed _ | Interface.Task.Failed _ -> + true + in + if already_finished then task_finished t end diff --git a/lib/task_server.mli b/lib/task_server.mli index 5ab32947..cffd7d92 100644 --- a/lib/task_server.mli +++ b/lib/task_server.mli @@ -113,4 +113,9 @@ module Task : functor (Interface : INTERFACE) -> sig (* Set a task not cancellable *) val prohibit_cancellation : task_handle -> unit + + (* When the task finishes automatically destroy it to avoid resource leaks. + Useful for asynchronous tasks that we don't wait for. + *) + val destroy_on_finish : task_handle -> unit end diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index 1d7cedc7..143baa36 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -551,6 +551,11 @@ module XenopsAPI (R : RPC) = struct declare "Task.list" ["List all the current tasks"] (debug_info_p @-> returning task_list_p err) + + let destroy_on_finish = + declare "Task.destroy_on_finish" + ["Ensures the task will be destroyed when it finishes"] + (debug_info_p @-> task_id_p @-> returning unit_p err) end module HOST = struct From 6bcd23ee81536028d1afa3176d62f2805b292eee Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 13 May 2022 14:01:50 +0000 Subject: [PATCH 05/13] Add featureset to xenopsd VM state This allows xapi to get the featureset as currently used by the VM. Signed-off-by: Rob Hoes (cherry-picked from xen-api/f18605f250ea7a7e1d33023078cdfc75f6021828) --- xen/xenops_types.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/xen/xenops_types.ml b/xen/xenops_types.ml index 87aaa353..9cb43b0b 100644 --- a/xen/xenops_types.ml +++ b/xen/xenops_types.ml @@ -194,6 +194,7 @@ module Vm = struct ; nomigrate: bool (** true means VM must not migrate *) ; nested_virt: bool (** true means VM uses nested virtualisation *) ; domain_type: domain_type + ; featureset: string } [@@deriving rpcty, sexp] end From 891f3b04f305dd4f4d8ba4c2ece0c6827764333b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 13 May 2022 14:03:07 +0000 Subject: [PATCH 06/13] Remove CPUID levelling v1 compat code Levelling v2 was introduced in the Dundee release (XS 7.0). Signed-off-by: Rob Hoes (cherry-picked from xen-api/f2a2b925a29fa56409c13a4a5ff2e9452c053830) --- xen/xenops_interface.ml | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index 143baa36..dd117486 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -466,7 +466,6 @@ module Host = struct ; features_hvm: int64 array ; features_pv_host: int64 array ; features_hvm_host: int64 array - ; features_oldstyle: int64 array } [@@deriving rpcty] @@ -615,15 +614,6 @@ module XenopsAPI (R : RPC) = struct let update_guest_agent_features = declare "HOST.update_guest_agent_features" [] (debug_info_p @-> feature_list_p @-> returning unit_p err) - - let upgrade_cpu_features = - let is_hvm_p = Param.mk ~name:"is_hvm" Types.bool in - declare "HOST.upgrade_cpu_features" [] - (debug_info_p - @-> cpu_features_array_p - @-> is_hvm_p - @-> returning cpu_features_array_p err - ) end module VM = struct From bb1f129e6ddebaee0396600d160132a3f1575159 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 16 May 2022 14:57:04 +0000 Subject: [PATCH 07/13] CA-363633: Always take the generation-id directly from xapi The generation-id of a VM is made up by xapi - specifically for Windows VMs - and xapi changes it or leaves it the same depending on the use case. One such use case is revert-from-checkpoint, where the reverted VM is expected to get a new generation-id. The generation-id is put into the plaformdata by xapi and xenopsd just writes it to xenstore when creating a domain. Because of a recent change, the platformdata is now persisted by xenopsd across suspend/resume and migration, and will therefore not take any new values that set by xapi in the VM metadata. Since a checkpoint is essentially a suspended VM, and a revert-from-checkpoint results in a VM that can subsequently be resumed, the VM now does not get a refreshed generation-id after this operation, which is a bug. To address this, the generation_id is given a dedicated field in the VM metadata for xenopsd, so that it behaves as before. Xenopsd itself then puts it into the platformdata when creating a domain. Signed-off-by: Rob Hoes (partially cherry picked from commit ff3b76a7b9459a4a714996ea533d8c5710a93e73) --- xen/xenops_types.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/xen/xenops_types.ml b/xen/xenops_types.ml index 9cb43b0b..d9ab03ad 100644 --- a/xen/xenops_types.ml +++ b/xen/xenops_types.ml @@ -160,6 +160,7 @@ module Vm = struct ; pci_msitranslate: bool ; pci_power_mgmt: bool ; has_vendor_device: bool [@default false] + ; generation_id: string option } [@@deriving rpcty, sexp] From 840d220a1d52dca5ea86e3a47b4b5ae7fa693f01 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 13 May 2022 15:41:25 +0000 Subject: [PATCH 08/13] Reformat Signed-off-by: Rob Hoes --- .ocamlformat | 1 - lib/debug.ml | 23 ++++++++++++----------- lib/task_server.ml | 6 ++---- 3 files changed, 14 insertions(+), 16 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index b4d356a7..ea8e56a8 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,4 @@ profile=ocamlformat -version=0.14.1 indicate-multiline-delimiters=closing-on-separate-line if-then-else=fit-or-vertical dock-collection-brackets=true diff --git a/lib/debug.ml b/lib/debug.ml index 8d34ced6..71e7fc74 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -47,15 +47,11 @@ module ThreadLocalTable = struct IntMap.find_opt id t.tbl end +type task = {desc: string; client: string option} -type task = { - desc: string - ; client: string option -} +let tasks : task ThreadLocalTable.t = ThreadLocalTable.make () -let tasks: task ThreadLocalTable.t = ThreadLocalTable.make () - -let names: string ThreadLocalTable.t = ThreadLocalTable.make () +let names : string ThreadLocalTable.t = ThreadLocalTable.make () let gettimestring () = let time = Unix.gettimeofday () in @@ -75,11 +71,16 @@ let format include_time brand priority message = let id = get_thread_id () in let task, name = (* if the task's client is known, attach it to the task's name *) - let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in + let name = + match ThreadLocalTable.find names with Some x -> x | None -> "" + in match ThreadLocalTable.find tasks with - | None -> "", name - | Some {desc; client=None} -> desc, name - | Some {desc; client=Some client} -> desc, Printf.sprintf "%s->%s" client name + | None -> + ("", name) + | Some {desc; client= None} -> + (desc, name) + | Some {desc; client= Some client} -> + (desc, Printf.sprintf "%s->%s" client name) in Printf.sprintf "[%s%5s||%d %s|%s|%s] %s" (if include_time then gettimestring () else "") diff --git a/lib/task_server.ml b/lib/task_server.ml index 0e416a1c..a0397508 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -162,8 +162,7 @@ functor let destroy task = let tasks = task.tasks in Mutex.execute tasks.m (fun () -> - tasks.task_map := SMap.remove task.id !(tasks.task_map) - ) + tasks.task_map := SMap.remove task.id !(tasks.task_map)) let task_finished item = if item.destroy_on_finish then ( @@ -298,8 +297,7 @@ functor (* If task is cancelling, just cancel it before setting it to not cancellable *) check_cancelling_locked task ; - task.cancellable <- false - ) + task.cancellable <- false) let destroy_on_finish t = t.destroy_on_finish <- true ; From d0bd6435623c9db4271c7858e3cd053ce6b5c755 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 27 Jun 2023 09:25:51 +0000 Subject: [PATCH 09/13] Introduce functions in CPU feature sets in xenopsd This introduces two functions in xenopsd, which correspond to functions used inside xapi to compute the pool-level CPU feature set and to do compatibility checks for VM live migration. A following commit changes xapi to use these functions instead of its own implementation. Later, the implementation of these two functions in xenopsd will be replaced by external library calls. At that point, CPU feature sets and all analysis on them will be completely abstract to xapi and xenopsd. Signed-off-by: Rob Hoes (cherry picked from commit https://github.com/xapi-project/xen-api/commit/6adebf6b0fca23e808d77d9b7115f30c628efd04) --- xen/dune | 2 +- xen/xenops_interface.ml | 85 +++++++++++++++++++++++++++++++++++++---- 2 files changed, 79 insertions(+), 8 deletions(-) diff --git a/xen/dune b/xen/dune index abd8acf6..5a9de348 100644 --- a/xen/dune +++ b/xen/dune @@ -15,7 +15,7 @@ (name xcp_xen_interface) (public_name xapi-idl.xen.interface) (modules xenops_interface) - (flags (:standard -w -39)) + (flags (:standard -w -39-27)) (libraries rpclib.core threads diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index dd117486..4c314839 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -197,6 +197,53 @@ module Network = struct type ts = t list [@@deriving rpcty] end +module CPU_policy : sig + type 'a t + + val of_string : 'a -> string -> 'a t + + val to_string : 'a t -> string + + val vm : [`vm] t Rpc.Types.def + + val host : [`host] t Rpc.Types.def + + val typ_of : 'a -> 'a t Rpc.Types.typ +end = struct + type 'a t = string [@@deriving rpc] + + let of_string _ s = s + + let to_string s = s + + let typ_of a = + Rpc.Types.( + Abstract + { + aname= "CPU_policy.t" + ; test_data= [] + ; rpc_of= rpc_of_t () + ; of_rpc= (fun x -> Ok (t_of_rpc a x)) + } + ) + + let vm = + Rpc.Types. + {name= "CPU_policy.vm"; description= ["VM CPU policy"]; ty= typ_of `vm} + + let host = + Rpc.Types. + { + name= "CPU_policy.host" + ; description= ["Host CPU policy"] + ; ty= typ_of `host + } +end + +type host_cpu_policy = [`host] CPU_policy.t + +let typ_of_host_cpu_policy = CPU_policy.typ_of `host + module Pci = struct include Xcp_pci @@ -581,13 +628,6 @@ module XenopsAPI (R : RPC) = struct Param.mk ~description:["The list of features"] ~name:"features" Host.guest_agent_feature_list - type cpu_features_array = int64 array [@@deriving rpcty] - - let cpu_features_array_p = - Param.mk - ~description:["An array containing the raw CPU feature flags"] - ~name:"features_array" cpu_features_array - let stat = declare "HOST.stat" ["Get the state of the host"] @@ -614,6 +654,37 @@ module XenopsAPI (R : RPC) = struct let update_guest_agent_features = declare "HOST.update_guest_agent_features" [] (debug_info_p @-> feature_list_p @-> returning unit_p err) + + let combine_cpu_policies = + let policy1_p = + Param.mk ~description:["CPU policy 1"] ~name:"policy1" CPU_policy.host + in + let policy2_p = + Param.mk ~description:["CPU policy 2"] ~name:"policy2" CPU_policy.host + in + let policy3_p = + Param.mk ~description:["Combined CPU policy"] ~name:"policy3" + CPU_policy.host + in + declare "HOST.combine_cpu_policies" + ["Combine CPU policy to get a common subset"] + (debug_info_p @-> policy1_p @-> policy2_p @-> returning policy3_p err) + + let is_compatible = + let vm_policy_p = + Param.mk ~description:["VM CPU policy"] ~name:"vm_policy" CPU_policy.vm + in + let host_policy_p = + Param.mk ~description:["Host CPU policy"] ~name:"host_policy" + CPU_policy.host + in + declare "HOST.is_compatible" + ["Check whether a VM can live-migrate to or resume on a host"] + (debug_info_p + @-> vm_policy_p + @-> host_policy_p + @-> returning (Param.mk Types.bool) err + ) end module VM = struct From f58558e42487691d4dd34281418c3651b5087272 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 27 Jun 2023 12:47:57 +0000 Subject: [PATCH 10/13] xenopsd: change type of reported CPU feature-sets to an abstract type Internally, feature sets are still strings of hex digits. However. the goal is for this to become opaque data for xapi. Signed-off-by: Rob Hoes (cherry picked from commit https://github.com/xapi-project/xen-api/commit/6491e058042e6897ad80c2e9e66e2898f5d87aec) --- xen/xenops_interface.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index 4c314839..55c69dbb 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -508,11 +508,11 @@ module Host = struct ; model: string ; stepping: string ; flags: string - ; features: int64 array - ; features_pv: int64 array - ; features_hvm: int64 array - ; features_pv_host: int64 array - ; features_hvm_host: int64 array + ; features: host_cpu_policy + ; features_pv: host_cpu_policy + ; features_hvm: host_cpu_policy + ; features_pv_host: host_cpu_policy + ; features_hvm_host: host_cpu_policy } [@@deriving rpcty] From 5d1e666b5d84635a701913892da9b55cfdc30a47 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Mon, 18 Sep 2023 15:42:26 +0100 Subject: [PATCH 11/13] CP-42182 Add CLI tool on xe and rrd-cli to enable saving of rrds to local host Backport of https://github.com/xapi-project/xen-api/pull/4908 This is spread over multiple repositories in the backport. Signed-off-by: Christian Lindig --- rrd/dune | 2 ++ rrd/rrd_cli.ml | 2 +- rrd/rrd_interface.ml | 9 +++++++++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/rrd/dune b/rrd/dune index 99763bb1..86da1121 100644 --- a/rrd/dune +++ b/rrd/dune @@ -44,6 +44,8 @@ (executable (name rrd_cli) + (public_name rrd-cli) + (package xapi-idl) (modules rrd_cli) (libraries cmdliner diff --git a/rrd/rrd_cli.ml b/rrd/rrd_cli.ml index 0046a252..db5b018c 100644 --- a/rrd/rrd_cli.ml +++ b/rrd/rrd_cli.ml @@ -17,7 +17,7 @@ let default_cmd = ] in ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) - , Cmdliner.Term.info "rrd_cli" ~version:(version_str Cmds.description) ~doc ) + , Cmdliner.Term.info "rrd-cli" ~version:(version_str Cmds.description) ~doc ) let cli () = let rpc = Rrd_client.rpc in diff --git a/rrd/rrd_interface.ml b/rrd/rrd_interface.ml index 9a9c6035..bf2633b4 100644 --- a/rrd/rrd_interface.ml +++ b/rrd/rrd_interface.ml @@ -246,6 +246,15 @@ module RPC_API (R : RPC) = struct ] (rem_addr_opt_p @-> unit_p @-> returning unit_p rrd_err) + let save_rrds = + declare "save_rrds" + [ + "Backs up RRD data to disk on localhost. This should be done \ + periodically to ensure" + ; "that if the host crashes we don't lose too much data." + ] + (unit_p @-> returning unit_p rrd_err) + let archive_rrd = declare "archive_rrd" [ From ad810bdd0b49a620aba204f4f4c2a984f81e1059 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Mon, 18 Sep 2023 15:42:26 +0100 Subject: [PATCH 12/13] CP-42182 Add CLI tool on xe and rrd-cli to enable saving of rrds to local host Backport of https://github.com/xapi-project/xen-api/pull/4908 Don't install the CLI tool from this repository and package becuase it is a library. The CLI implementation moved to xcp-rrdd. Signed-off-by: Christian Lindig --- rrd/dune | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/rrd/dune b/rrd/dune index 86da1121..fa1e34ed 100644 --- a/rrd/dune +++ b/rrd/dune @@ -44,8 +44,9 @@ (executable (name rrd_cli) - (public_name rrd-cli) - (package xapi-idl) + ; don't install, executable is in xcp-rrdd + ; (public_name rrd-cli) + ; (package xapi-idl) (modules rrd_cli) (libraries cmdliner From a3d473bd94f3afdbedcd91c78b348554d875b160 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Mon, 18 Sep 2023 15:42:26 +0100 Subject: [PATCH 13/13] CP-42182 remove rrd-cli, it's now in xcp-rrdd Backport of https://github.com/xapi-project/xen-api/pull/4908 Don't install the CLI tool from this repository and package becuase it is a library. The CLI implementation moved to xcp-rrdd. Signed-off-by: Christian Lindig --- rrd/dune | 20 +------------------- rrd/rrd_cli.ml | 27 --------------------------- 2 files changed, 1 insertion(+), 46 deletions(-) delete mode 100644 rrd/rrd_cli.ml diff --git a/rrd/dune b/rrd/dune index fa1e34ed..8051f3a9 100644 --- a/rrd/dune +++ b/rrd/dune @@ -30,7 +30,7 @@ (library (name xcp_rrd) (public_name xapi-idl.rrd) - (modules (:standard \ data_source rrd_interface rrd_cli)) + (modules (:standard \ data_source rrd_interface)) (flags (:standard -w -39)) (libraries rpclib.core @@ -42,21 +42,3 @@ (wrapped false) (preprocess (pps ppx_deriving_rpc))) -(executable - (name rrd_cli) - ; don't install, executable is in xcp-rrdd - ; (public_name rrd-cli) - ; (package xapi-idl) - (modules rrd_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.rrd - )) - -(rule - (alias runtest) - (deps (:x rrd_cli.exe)) - (action (run %{x}))) - diff --git a/rrd/rrd_cli.ml b/rrd/rrd_cli.ml deleted file mode 100644 index db5b018c..00000000 --- a/rrd/rrd_cli.ml +++ /dev/null @@ -1,27 +0,0 @@ -(* Rrd CLI *) - -module Cmds = Rrd_interface.RPC_API (Cmdlinergen.Gen ()) - -let version_str description = - let maj, min, mic = description.Idl.Interface.version in - Printf.sprintf "%d.%d.%d" maj min mic - -let default_cmd = - let doc = - String.concat "" - [ - "A CLI for the Db monitoring API. This allows scripting of the Rrd \ - daemon " - ; "for testing and debugging. This tool is not intended to be used as an " - ; "end user tool" - ] - in - ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) - , Cmdliner.Term.info "rrd-cli" ~version:(version_str Cmds.description) ~doc ) - -let cli () = - let rpc = Rrd_client.rpc in - Cmdliner.Term.eval_choice default_cmd - (List.map (fun t -> t rpc) (Cmds.implementation ())) - -let _ = cli ()