From f8f3d6198878e8d2dde265695c022ae646d4540a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 4 Dec 2023 15:17:24 +0000 Subject: [PATCH 01/10] CP-46851: Allow metadata-exports of snapshots I am not sure where this restriction came from. It was introduced in the same commit that introduced the metadata-export feature itself, without explanation. Full exports of snapshots are already allowed. Signed-off-by: Rob Hoes --- ocaml/xapi/export.ml | 10 ---------- quality-gate.sh | 2 +- 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 49ccc7b0c57..93572247076 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -771,16 +771,6 @@ let metadata_handler (req : Request.t) s _ = else [vm_from_request ~__context req] in - if - (not export_all) - && Db.VM.get_is_a_snapshot ~__context ~self:(List.hd vm_refs) - then - raise - (Api_errors.Server_error - ( Api_errors.operation_not_allowed - , ["Exporting metadata of a snapshot is not allowed"] - ) - ) ; let task_id = Ref.string_of (Context.get_task_id __context) in let read_fd, write_fd = Unix.pipe () in let export_error = ref None in diff --git a/quality-gate.sh b/quality-gate.sh index 77238f4ab93..ffbe1745d23 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=318 + N=317 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" From 1141b8a9a448cdc4b1bed518665ff72f545e6e26 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 9 Jan 2024 17:01:43 +0000 Subject: [PATCH 02/10] CP-46851: return snapshot refs when importing exclusively snapshots This allows clients to know which snapshots they knowingly just created and act on them instead of looking again into the db and try to divine which snapshots the call created. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/import.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index fd6d898b1e0..01e5ca25640 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -2158,11 +2158,18 @@ let complete_import ~__context vmrefs = Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm ) vmrefs ; - (* We only keep VMs which are not snapshot *) + (* When only snapshots have been imported, return all of them. + Otherwise, only keep VMs which are not snapshots *) let vmrefs = - List.filter - (fun vmref -> not (Db.VM.get_is_a_snapshot ~__context ~self:vmref)) + let non_snapshots = + List.filter + (fun x -> not (Db.VM.get_is_a_snapshot ~__context ~self:x)) + vmrefs + in + if non_snapshots = [] then vmrefs + else + non_snapshots in (* We only set the result on the task since it is officially completed later. *) TaskHelper.set_result ~__context (Some (API.rpc_of_ref_VM_set vmrefs)) From e9431c6a003d93ee511e582ee73a288663f7aec0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 16 Jan 2024 10:36:34 +0000 Subject: [PATCH 03/10] CP-46851: Add metadata_export to VM.allowed_operations This allows clients to detect that the newer device type exclusions for export are available. Signed-off-by: Rob Hoes --- ocaml/xapi/xapi_vm_lifecycle.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index d90da39619e..7d35a12f1d0 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -790,6 +790,7 @@ let update_allowed_operations ~__context ~self = ; `changing_dynamic_range ; `changing_NVRAM ; `create_vtpm + ; `metadata_export ] in (* FIXME: need to be able to deal with rolling-upgrade for orlando as well *) From f48b8787675da239eb6d839ae86f26c2464eedc2 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 19 Mar 2024 17:34:46 +0000 Subject: [PATCH 04/10] CP-46851: add parameter to skip device types on get_export_metadata This allows to orchestrators to copy devices like VBDs from the VM, export the metadata without the disk, import the VM to any pool, and finally add the saved VBDs to the new VM before booting it. Signed-off-by: Pau Ruiz Safont --- ocaml/idl/datamodel.ml | 1 + ocaml/xapi/export.ml | 127 ++++++++++++++++++++----------------- ocaml/xapi/importexport.ml | 31 +++++++++ ocaml/xapi/xapi_dr.ml | 1 + 4 files changed, 102 insertions(+), 58 deletions(-) diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index c8fa2614150..a9f219e91af 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -8177,6 +8177,7 @@ let http_actions = ; Bool_query_arg "include_dom0" ; Bool_query_arg "include_vhd_parents" ; Bool_query_arg "export_snapshots" + ; String_query_arg "excluded_device_types" ] , _R_VM_ADMIN , [] diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 93572247076..54a494ac240 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -52,7 +52,7 @@ let make_id = "Ref:" ^ string_of_int this let rec update_table ~__context ~include_snapshots ~preserve_power_state - ~include_vhd_parents ~table vm = + ~include_vhd_parents ~table ~excluded_devices vm = let add r = if not (Hashtbl.mem table (Ref.string_of r)) then Hashtbl.add table (Ref.string_of r) (make_id ()) @@ -77,38 +77,40 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state then ( add vm ; let vm = Db.VM.get_record ~__context ~self:vm in - List.iter - (fun vif -> - if Db.is_valid_ref __context vif then ( - add vif ; - let vif = Db.VIF.get_record ~__context ~self:vif in - add vif.API.vIF_network + if not (List.mem Devicetype.VIF excluded_devices) then + List.iter + (fun vif -> + if Db.is_valid_ref __context vif then ( + add vif ; + let vif = Db.VIF.get_record ~__context ~self:vif in + add vif.API.vIF_network + ) ) - ) - vm.API.vM_VIFs ; - List.iter - (fun vbd -> - if Db.is_valid_ref __context vbd then ( - add vbd ; - let vbd = Db.VBD.get_record ~__context ~self:vbd in - if not vbd.API.vBD_empty then - add_vdi vbd.API.vBD_VDI + vm.API.vM_VIFs ; + if not (List.mem Devicetype.VBD excluded_devices) then + List.iter + (fun vbd -> + if Db.is_valid_ref __context vbd then ( + add vbd ; + let vbd = Db.VBD.get_record ~__context ~self:vbd in + if not vbd.API.vBD_empty then + add_vdi vbd.API.vBD_VDI + ) ) - ) - vm.API.vM_VBDs ; - List.iter - (fun vgpu -> - if Db.is_valid_ref __context vgpu then ( - add vgpu ; - let vgpu = Db.VGPU.get_record ~__context ~self:vgpu in - add vgpu.API.vGPU_type ; - add vgpu.API.vGPU_GPU_group + vm.API.vM_VBDs ; + if not (List.mem Devicetype.VGPU excluded_devices) then + List.iter + (fun vgpu -> + if Db.is_valid_ref __context vgpu then ( + add vgpu ; + let vgpu = Db.VGPU.get_record ~__context ~self:vgpu in + add vgpu.API.vGPU_type ; + add vgpu.API.vGPU_GPU_group + ) ) - ) - vm.API.vM_VGPUs ; + vm.API.vM_VGPUs ; (* add all PVS proxies that have a VIF belonging to this VM, add their - * PVS sites as well - *) + PVS sites as well *) Db.PVS_proxy.get_all_records ~__context |> List.filter (fun (_, p) -> List.mem p.API.pVS_proxy_VIF vm.API.vM_VIFs) |> List.iter (fun (ref, proxy) -> @@ -118,15 +120,16 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state ) ) ; (* add VTPMs that belong to this VM *) - vm.API.vM_VTPMs - |> List.iter (fun ref -> if Db.is_valid_ref __context ref then add ref) ; + if not (List.mem Devicetype.VTPM excluded_devices) then + vm.API.vM_VTPMs + |> List.iter (fun ref -> if Db.is_valid_ref __context ref then add ref) ; (* If we need to include snapshots, update the table for VMs in the 'snapshots' field *) if include_snapshots then List.iter (fun snap -> update_table ~__context ~include_snapshots:false ~preserve_power_state - ~include_vhd_parents ~table snap + ~include_vhd_parents ~table ~excluded_devices snap ) vm.API.vM_snapshots ; (* If VM is suspended then add the suspend_VDI *) @@ -145,7 +148,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state (* Add the parent VM *) if include_snapshots && Db.is_valid_ref __context vm.API.vM_parent then update_table ~__context ~include_snapshots:false ~preserve_power_state - ~include_vhd_parents ~table vm.API.vM_parent + ~include_vhd_parents ~table ~excluded_devices vm.API.vM_parent ) (** Walk the graph of objects and update the table of Ref -> ids for each object we wish @@ -580,11 +583,11 @@ let make_all ~with_snapshot_metadata ~preserve_power_state table __context = on metadata-export, include snapshots fields of the exported VM as well as the VM records of VMs which are snapshots of the exported VM. *) let vm_metadata ~with_snapshot_metadata ~preserve_power_state - ~include_vhd_parents ~__context ~vms = + ~include_vhd_parents ~__context ~vms ~excluded_devices = let table = create_table () in List.iter (update_table ~__context ~include_snapshots:with_snapshot_metadata - ~preserve_power_state ~include_vhd_parents ~table + ~preserve_power_state ~include_vhd_parents ~table ~excluded_devices ) vms ; let objects = @@ -603,7 +606,7 @@ let string_of_vm ~__context vm = (** Export a VM's metadata only *) let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state - ~include_vhd_parents ~vms s = + ~include_vhd_parents ~vms ~excluded_devices s = ( match vms with | [] -> failwith "need to specify at least one VM" @@ -624,7 +627,7 @@ let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state ) ; let _, ova_xml = vm_metadata ~with_snapshot_metadata ~preserve_power_state - ~include_vhd_parents ~__context ~vms + ~include_vhd_parents ~__context ~vms ~excluded_devices in let hdr = Tar.Header.make Xapi_globs.ova_xml_filename @@ -640,7 +643,7 @@ let export refresh_session __context rpc session_id s vm_ref (string_of_bool preserve_power_state) ; let table, ova_xml = vm_metadata ~with_snapshot_metadata:false ~preserve_power_state - ~include_vhd_parents:false ~__context ~vms:[vm_ref] + ~include_vhd_parents:false ~__context ~vms:[vm_ref] ~excluded_devices:[] in debug "Outputting ova.xml" ; let hdr = @@ -716,35 +719,43 @@ let vm_from_request ~__context (req : Request.t) = Client.VM.get_by_uuid ~rpc ~session_id ~uuid ) -let bool_from_request ~__context (req : Request.t) default k = - if List.mem_assoc k req.Request.query then - bool_of_string (List.assoc k req.Request.query) - else - default +let arg_from_request (req : Request.t) k = List.assoc_opt k req.Request.query -let export_all_vms_from_request ~__context (req : Request.t) = - bool_from_request ~__context req false "all" +let bool_from_request req default k = + arg_from_request req k |> Option.fold ~none:default ~some:bool_of_string + +let devicetypelist_from_request req default k = + let to_list = function + | "" -> + [] + | x -> + String.split_on_char ',' x |> List.map Devicetype.of_string + in + arg_from_request req k |> Option.fold ~none:default ~some:to_list -let include_vhd_parents_from_request ~__context (req : Request.t) = - bool_from_request ~__context req false "include_vhd_parents" +let export_all_vms_from_request req = bool_from_request req false "all" -let export_snapshots_from_request ~__context (req : Request.t) = - bool_from_request ~__context req true "export_snapshots" +let include_vhd_parents_from_request req = + bool_from_request req false "include_vhd_parents" -let include_dom0_from_request ~__context (req : Request.t) = - bool_from_request ~__context req true "include_dom0" +let export_snapshots_from_request req = + bool_from_request req true "export_snapshots" + +let include_dom0_from_request req = bool_from_request req true "include_dom0" + +let excluded_devices_from_request req = + devicetypelist_from_request req [] "excluded_device_types" let metadata_handler (req : Request.t) s _ = debug "metadata_handler called" ; req.Request.close <- true ; (* Xapi_http.with_context always completes the task at the end *) Xapi_http.with_context "VM.export_metadata" req s (fun __context -> - let include_vhd_parents = - include_vhd_parents_from_request ~__context req - in - let export_all = export_all_vms_from_request ~__context req in - let export_snapshots = export_snapshots_from_request ~__context req in - let include_dom0 = include_dom0_from_request ~__context req in + let include_vhd_parents = include_vhd_parents_from_request req in + let export_all = export_all_vms_from_request req in + let export_snapshots = export_snapshots_from_request req in + let include_dom0 = include_dom0_from_request req in + let excluded_devices = excluded_devices_from_request req in (* Get the VM refs. In case of exporting the metadata of a particular VM, return a singleton list containing the vm ref. *) (* In case of exporting all the VMs metadata, get all the VM records which are not default templates. *) let vm_refs = @@ -790,7 +801,7 @@ let metadata_handler (req : Request.t) s _ = vm_refs ; export_metadata ~with_snapshot_metadata:export_snapshots ~preserve_power_state:true ~include_vhd_parents - ~__context ~vms:vm_refs write_fd + ~excluded_devices ~__context ~vms:vm_refs write_fd ) (fun () -> Unix.close write_fd ; diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index a7354fce45e..f90a8da80ea 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -469,6 +469,37 @@ module Format = struct (* default *) end +module Devicetype = struct + type t = VIF | VBD | VGPU | VTPM + + let all = [VIF; VBD; VGPU; VTPM] + + let to_string = function + | VIF -> + "vif" + | VBD -> + "vbd" + | VGPU -> + "vgpu" + | VTPM -> + "vtpm" + + let of_string x = + match String.lowercase_ascii x with + | "vif" -> + VIF + | "vbd" -> + VBD + | "vgpu" -> + VGPU + | "vtpm" -> + VTPM + | other -> + let fail fmt = Printf.kprintf failwith fmt in + fail "%s: Type '%s' not one of [%s]" __FUNCTION__ other + (String.concat "; " (List.map to_string all)) +end + let return_302_redirect (req : Http.Request.t) s address = let address = Http.Url.maybe_wrap_IPv6_literal address in let url = diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml index e9c1c53ad0c..bdbb4dee6c2 100644 --- a/ocaml/xapi/xapi_dr.ml +++ b/ocaml/xapi/xapi_dr.ml @@ -245,6 +245,7 @@ let create_import_objects ~__context ~vms = List.iter (Export.update_table ~__context ~include_snapshots:true ~preserve_power_state:true ~include_vhd_parents:false ~table + ~excluded_devices:[] ) vms ; Export.make_all ~with_snapshot_metadata:true ~preserve_power_state:true table From e67585c58d40cc52fc4a93aa22a9d75879e45e69 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 21 Mar 2024 13:53:07 +0000 Subject: [PATCH 05/10] CP-46851: Add device types excluded to exports in xe-cli This allows to easily test the http endpoint. Also advertises the metadata parameter on these calls Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-cli-server/cli_frontend.ml | 18 +++++++++++++++--- ocaml/xapi-cli-server/cli_operations.ml | 13 ++++++++++--- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index f8aa043eb5a..58ecb6cc88c 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -1756,7 +1756,13 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "vm-export" , { reqd= ["filename"] - ; optn= ["preserve-power-state"; "compress"] + ; optn= + [ + "preserve-power-state" + ; "compress" + ; "metadata" + ; "excluded-device-types" + ] ; help= "Export a VM to ." ; implementation= With_fd Cli_operations.vm_export ; flags= [Standard; Vm_selectors] @@ -1798,7 +1804,13 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "snapshot-export-to-template" , { reqd= ["filename"; "snapshot-uuid"] - ; optn= ["preserve-power-state"] + ; optn= + [ + "preserve-power-state" + ; "compress" + ; "metadata" + ; "excluded-device-types" + ] ; help= "Export a snapshot to ." ; implementation= With_fd Cli_operations.snapshot_export ; flags= [Standard] @@ -1863,7 +1875,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "template-export" , { reqd= ["filename"; "template-uuid"] - ; optn= [] + ; optn= ["compress"; "metadata"; "excluded-device-types"] ; help= "Export a template to ." ; implementation= With_fd Cli_operations.template_export ; flags= [Standard] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index bc0d9ea30bc..27a62085453 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -5867,7 +5867,13 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid else vm_metadata_only in - let vm_metadata_only = get_bool_param params "metadata" in + let extra_args = + if vm_metadata_only then + Printf.sprintf "&excluded_device_types=%s" + (get_param params ~default:"" "excluded-device-types") + else + "" + in let vm_record = vm.record () in let exporttask, task_destroy_fn = match task_uuid with @@ -5893,7 +5899,7 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid let f = if !num > 1 then filename ^ string_of_int !num else filename in download_file rpc session_id exporttask fd f (Printf.sprintf - "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b" + "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b%s" ( if vm_metadata_only then Constants.export_metadata_uri else @@ -5903,7 +5909,7 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid (Ref.string_of (vm.getref ())) Constants.use_compression (Compression_algorithms.to_string compression) - preserve_power_state export_snapshots + preserve_power_state export_snapshots extra_args ) "Export" ; num := !num + 1 @@ -5939,6 +5945,7 @@ let vm_export fd printer rpc session_id params = ; "compress" ; "preserve-power-state" ; "include-snapshots" + ; "excluded-device-types" ] ) From d772c3904dc516edb75e539d528357139a6a02ec Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 20 Mar 2024 15:41:39 +0000 Subject: [PATCH 06/10] xapi-cli-server: simplify vm-export and helpers Use the helper functions to process parameters, use atomics instead of ad-hoc references for counting in possibly-parallel case Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-cli-server/cli_operations.ml | 218 +++++++++--------------- ocaml/xapi-cli-server/record_util.ml | 11 +- quality-gate.sh | 2 +- 3 files changed, 91 insertions(+), 140 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 27a62085453..4f28a48848d 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -32,26 +32,10 @@ let failwith str = raise (Cli_util.Cli_failure str) exception ExitWithError of int let bool_of_string param string = - let s = String.lowercase_ascii string in - match s with - | "true" -> - true - | "t" -> - true - | "1" -> - true - | "false" -> - false - | "f" -> - false - | "0" -> - false - | _ -> - failwith - ("Failed to parse parameter '" - ^ param - ^ "': expecting 'true' or 'false'" - ) + try Record_util.bool_of_string string + with Record_util.Record_failure msg -> + let msg = Printf.sprintf "Failed to parse parameter '%s': %s" param msg in + raise (Record_util.Record_failure msg) let get_bool_param params ?(default = false) param = List.assoc_opt param params @@ -66,6 +50,24 @@ let get_float_param params param ~default = let get_param params param ~default = Option.value ~default (List.assoc_opt param params) +let get_set_param params ?(default = []) param = + List.assoc_opt param params + |> Option.map (String.split_on_char ',') + |> Option.value ~default + +let get_map_param params ?(default = []) param = + let get_map x = + String.split_on_char ',' x + |> List.filter_map (fun x -> + match String.split_on_char ':' x with + | [k; v] -> + Some (k, v) + | _ -> + None + ) + in + List.assoc_opt param params |> Option.map get_map |> Option.value ~default + (** [get_unique_param param params] is intended to replace [List.assoc_opt] in the cases where a parameter can only exist once, as repeating it might force the CLI to make choices the user didn't foresee. In those cases @@ -1520,16 +1522,15 @@ let pool_management_reconfigure (_ : printer) rpc session_id params = let pool_join printer rpc session_id params = try let force = get_bool_param params "force" in + let master_address = List.assoc "master-address" params in + let master_username = List.assoc "master-username" params in + let master_password = List.assoc "master-password" params in if force then - Client.Pool.join_force ~rpc ~session_id - ~master_address:(List.assoc "master-address" params) - ~master_username:(List.assoc "master-username" params) - ~master_password:(List.assoc "master-password" params) + Client.Pool.join_force ~rpc ~session_id ~master_address ~master_username + ~master_password else - Client.Pool.join ~rpc ~session_id - ~master_address:(List.assoc "master-address" params) - ~master_username:(List.assoc "master-username" params) - ~master_password:(List.assoc "master-password" params) ; + Client.Pool.join ~rpc ~session_id ~master_address ~master_username + ~master_password ; printer (Cli_printer.PList [ @@ -3264,11 +3265,11 @@ let do_vm_op ?(include_control_vms = false) ?(include_template_vms = false) select_vms ~include_control_vms ~include_template_vms rpc session_id params ignore_params in - match List.length vms with - | 0 -> + match vms with + | [] -> failwith "No matching VMs found" - | 1 -> - [op (List.hd vms)] + | [vm] -> + [op vm] | _ -> if multiple && get_bool_param params "multiple" then do_multiple op vms @@ -3310,11 +3311,11 @@ let do_host_op rpc session_id op params ?(multiple = true) ignore_params = let do_sr_op rpc session_id op params ?(multiple = true) ignore_params = let srs = select_srs rpc session_id params ignore_params in - match List.length srs with - | 0 -> + match srs with + | [] -> failwith "No matching hosts found" - | 1 -> - [op (List.hd srs)] + | [sr] -> + [op sr] | _ -> if multiple && get_bool_param params "multiple" then do_multiple op srs @@ -5575,12 +5576,7 @@ let vm_import fd _printer rpc session_id params = raise (Cli_util.Cli_failure "No SR specified and Pool default SR is null") in - let _type = - if List.mem_assoc "type" params then - List.assoc "type" params - else - "default" - in + let _type = get_param ~default:"default" params "type" in let full_restore = get_bool_param params "preserve" in let vm_metadata_only = get_bool_param params "metadata" in let force = get_bool_param params "force" in @@ -5806,9 +5802,7 @@ let blob_put fd _printer rpc session_id params = let blob_create printer rpc session_id params = let name = List.assoc "name" params in let mime_type = Listext.assoc_default "mime-type" params "" in - let public = - try bool_of_string "public" (List.assoc "public" params) with _ -> false - in + let public = get_bool_param params "public" in if List.mem_assoc "vm-uuid" params then let uuid = List.assoc "vm-uuid" params in let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in @@ -5860,19 +5854,16 @@ let blob_create printer rpc session_id params = let export_common fd _printer rpc session_id params filename num ?task_uuid compression preserve_power_state vm = - let vm_metadata_only : bool = get_bool_param params "metadata" in - let export_snapshots : bool = - if List.mem_assoc "include-snapshots" params then - bool_of_string "include-snapshots" (List.assoc "include-snapshots" params) - else - vm_metadata_only - in - let extra_args = + let vm_metadata_only = get_bool_param params "metadata" in + let export_snapshots = get_bool_param params "include-snapshots" in + let uri, extra_args = if vm_metadata_only then - Printf.sprintf "&excluded_device_types=%s" - (get_param params ~default:"" "excluded-device-types") + ( Constants.export_metadata_uri + , Printf.sprintf "&excluded_device_types=%s" + (get_param params ~default:"" "excluded-device-types") + ) else - "" + (Constants.export_uri, "") in let vm_record = vm.record () in let exporttask, task_destroy_fn = @@ -5890,49 +5881,40 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid (* do not destroy the task that has been received *) (Client.Task.get_by_uuid ~rpc ~session_id ~uuid:task_uuid, fun () -> ()) in - (* Initially mark the task progress as -1.0. The first thing the export handler does it to mark it as zero *) - (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *) - (* not our responsibility any more to mark the task as completed/failed/etc. *) + (* Initially mark the task progress as -1.0. The first thing the export + handler does it to mark it as zero. This is used as a flag to show that + the 'ownership' of the task has been passed to the handler, and it's + not our responsibility any more to mark the task as completed/failed/etc. + *) Client.Task.set_progress ~rpc ~session_id ~self:exporttask ~value:(-1.0) ; finally (fun () -> - let f = if !num > 1 then filename ^ string_of_int !num else filename in + let num = Atomic.fetch_and_add num 1 in + let f = if num > 1 then filename ^ string_of_int num else filename in download_file rpc session_id exporttask fd f (Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b%s" - ( if vm_metadata_only then - Constants.export_metadata_uri - else - Constants.export_uri - ) - (Ref.string_of session_id) (Ref.string_of exporttask) + uri (Ref.string_of session_id) (Ref.string_of exporttask) (Ref.string_of (vm.getref ())) Constants.use_compression (Compression_algorithms.to_string compression) preserve_power_state export_snapshots extra_args ) - "Export" ; - num := !num + 1 + "Export" ) (fun () -> task_destroy_fn ()) let get_compression_algorithm params = - if List.mem_assoc "compress" params then - Compression_algorithms.of_string (List.assoc "compress" params) - else - None + Option.bind + (List.assoc_opt "compress" params) + Compression_algorithms.of_string let vm_export fd printer rpc session_id params = let filename = List.assoc "filename" params in let compression = get_compression_algorithm params in let preserve_power_state = get_bool_param params "preserve-power-state" in - let task_uuid = - if List.mem_assoc "task-uuid" params then - Some (List.assoc "task-uuid" params) - else - None - in - let num = ref 1 in + let task_uuid = List.assoc_opt "task-uuid" params in + let num = Atomic.make 1 in let op vm = export_common fd printer rpc session_id params filename num ?task_uuid compression preserve_power_state vm @@ -5953,32 +5935,23 @@ let vm_export_aux obj_type fd printer rpc session_id params = let filename = List.assoc "filename" params in let compression = get_compression_algorithm params in let preserve_power_state = get_bool_param params "preserve-power-state" in - let num = ref 1 in let uuid = List.assoc (obj_type ^ "-uuid") params in - let ref = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in - if - obj_type = "template" - && not (Client.VM.get_is_a_template ~rpc ~session_id ~self:ref) - then - failwith - (Printf.sprintf - "This operation can only be performed on a VM template. %s is not a \ - VM template." - uuid - ) ; - if - obj_type = "snapshot" - && not (Client.VM.get_is_a_snapshot ~rpc ~session_id ~self:ref) - then - failwith - (Printf.sprintf - "This operation can only be performed on a VM snapshot. %s is not a \ - VM snapshot." - uuid - ) ; + let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in + let is_template () = Client.VM.get_is_a_template ~rpc ~session_id ~self:vm in + let is_snapshot () = Client.VM.get_is_a_snapshot ~rpc ~session_id ~self:vm in + let msg () = + Printf.sprintf + "This operation can only be performed on a VM %s. %s is not a VM %s." + obj_type uuid obj_type + in + if obj_type = "template" && not (is_template ()) then + failwith (msg ()) ; + if obj_type = "snapshot" && not (is_snapshot ()) then + failwith (msg ()) ; + let num = Atomic.make 1 in export_common fd printer rpc session_id params filename num compression preserve_power_state - (vm_record rpc session_id ref) + (vm_record rpc session_id vm) let vm_copy_bios_strings printer rpc session_id params = let host = @@ -7356,7 +7329,7 @@ let vmss_create printer rpc session_id params = let schedule = read_map_params "schedule" params in (* optional parameters with default values *) let name_description = get "name-description" ~default:"" in - let enabled = Record_util.bool_of_string (get "enabled" ~default:"true") in + let enabled = get_bool_param ~default:true params "enabled" in let retained_snapshots = Int64.of_string (get "retained-snapshots" ~default:"7") in @@ -7925,13 +7898,7 @@ module VTPM = struct let create printer rpc session_id params = let vm_uuid = List.assoc "vm-uuid" params in let vM = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in - let is_unique = - match List.assoc_opt "is_unique" params with - | Some value -> - bool_of_string "is_unique" value - | None -> - false - in + let is_unique = get_bool_param params "is_unique" in let ref = Client.VTPM.create ~rpc ~session_id ~vM ~is_unique in let uuid = Client.VTPM.get_uuid ~rpc ~session_id ~self:ref in printer (Cli_printer.PList [uuid]) @@ -7947,33 +7914,12 @@ module Observer = struct let create printer rpc session_id params = let name_label = List.assoc "name-label" params in let hosts = - List.assoc_opt "host-uuids" params - |> Option.fold ~none:[] ~some:(fun host_uuids -> - List.map - (fun uuid -> Client.Host.get_by_uuid ~rpc ~session_id ~uuid) - (String.split_on_char ',' host_uuids) - ) - in - let name_description = - List.assoc_opt "name-description" params |> Option.value ~default:"" - in - let enabled = - List.assoc_opt "enabled" params - |> Option.fold ~none:false ~some:(fun s -> - try Stdlib.bool_of_string s with _ -> false - ) - in - let attributes = - List.assoc_opt "attributes" params - |> Option.fold ~none:[] ~some:(String.split_on_char ',') - |> List.filter_map (fun kv -> - match String.split_on_char ':' kv with - | [k; v] -> - Some (k, v) - | _ -> - None - ) + get_set_param params "host-uuids" + |> List.map (fun uuid -> Client.Host.get_by_uuid ~rpc ~session_id ~uuid) in + let name_description = get_param ~default:"" params "name-description" in + let enabled = get_bool_param params "enabled" in + let attributes = get_map_param params "attributes" in let endpoints = List.assoc_opt "endpoints" params |> Option.fold ~none:[Tracing.bugtool_name] diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 5332c2aee16..8fbd141e908 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -953,12 +953,17 @@ let cluster_host_operation_to_string op = let bool_of_string s = match String.lowercase_ascii s with - | "true" | "yes" -> + | "true" | "t" | "yes" | "y" | "1" -> true - | "false" | "no" -> + | "false" | "f" | "no" | "n" | "0" -> false | _ -> - raise (Record_failure ("Expected 'true','yes','false','no', got " ^ s)) + raise + (Record_failure + ("Expected 'true','t','yes','y','1','false','f','no','n','0' got " + ^ s + ) + ) let sdn_protocol_of_string s = match String.lowercase_ascii s with diff --git a/quality-gate.sh b/quality-gate.sh index ffbe1745d23..56e53e75b56 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=317 + N=315 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" From f237795fb1ec344c47587f8227f9d047adcf3ef1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 19 Mar 2024 17:38:22 +0000 Subject: [PATCH 07/10] datamodel_vm: fix typo Signed-off-by: Pau Ruiz Safont --- ocaml/idl/datamodel_vm.ml | 2 +- ocaml/idl/schematest.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index c1a6b9a7d9c..aa45d93de5b 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1899,7 +1899,7 @@ let t = ; field ~qualifier:DynamicRO ~ty:(Set (Ref _vbd)) "VBDs" "virtual block devices" ; field ~qualifier:DynamicRO ~ty:(Set (Ref _vusb)) "VUSBs" - "vitual usb devices" + "virtual usb devices" ; field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO ~ty:(Set (Ref _crashdump)) "crash_dumps" "crash dumps associated with this VM" diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index c8e5972c9a6..82619e8393d 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "186131ad48f40dff30246e8e0c0dbf0a" +let last_known_schema_hash = "a55d5dc70920dcf4ab72ed321497b482" let current_schema_hash : string = let open Datamodel_types in From 5013382c806a85baf75a3b25ce65fa4871766291 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 19 Mar 2024 17:39:00 +0000 Subject: [PATCH 08/10] .git-blame-ignore-revs: ignore another reformatting commit Signed-off-by: Pau Ruiz Safont --- .git-blame-ignore-revs | 1 + 1 file changed, 1 insertion(+) diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index 4c2762b5222..d8259ca9cd8 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -29,6 +29,7 @@ b020cf35a1f2c274f95a4118d4596043cba6113f ff39018fd6d91985f9c893a56928771dfe9fa48d cbb9edb17dfd122c591beb14d1275acc39492335 d6ab15362548b8fe270bd14d5153b8d94e1b15c0 +b12cf444edea15da6274975e1b2ca6a7fce2a090 # ocp-indent d018d26d6acd4707a23288b327b49e44f732725e From 85d5c862c2ebe262d8bd293dd6622f202aedf19d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 21 Mar 2024 17:51:31 +0000 Subject: [PATCH 09/10] xapi/export: do not miss parameters for export_metadata on logs Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/export.ml | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 54a494ac240..6dd810261b9 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -607,23 +607,22 @@ let string_of_vm ~__context vm = (** Export a VM's metadata only *) let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state ~include_vhd_parents ~vms ~excluded_devices s = + let infomsg vm = + info + "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \ + include_vhd_parents = '%b'; preserve_power_state = '%s'; \ + excluded_devices = '%s'" + vm with_snapshot_metadata include_vhd_parents + (string_of_bool preserve_power_state) + (String.concat ", " (List.map Devicetype.to_string excluded_devices)) + in ( match vms with | [] -> failwith "need to specify at least one VM" | [vm] -> - info - "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \ - include_vhd_parents = '%b'; preserve_power_state = '%s" - (string_of_vm ~__context vm) - with_snapshot_metadata include_vhd_parents - (string_of_bool preserve_power_state) + infomsg (string_of_vm ~__context vm) | vms -> - info - "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \ - preserve_power_state = '%s" - (String.concat ", " (List.map (string_of_vm ~__context) vms)) - with_snapshot_metadata - (string_of_bool preserve_power_state) + infomsg (String.concat ", " (List.map (string_of_vm ~__context) vms)) ) ; let _, ova_xml = vm_metadata ~with_snapshot_metadata ~preserve_power_state From 0c6805ffaaa55fdb982901ab6a2d587ffc06225e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 25 Mar 2024 15:22:13 +0000 Subject: [PATCH 10/10] xapi/export: set a date when generating tarballs Tooling complains about using 1970 as the date otherwise Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/export.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 6dd810261b9..c549fb74295 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -616,6 +616,7 @@ let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state (string_of_bool preserve_power_state) (String.concat ", " (List.map Devicetype.to_string excluded_devices)) in + let now = Date.now () |> Date.to_unix_time |> Int64.of_float in ( match vms with | [] -> failwith "need to specify at least one VM" @@ -629,7 +630,7 @@ let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state ~include_vhd_parents ~__context ~vms ~excluded_devices in let hdr = - Tar.Header.make Xapi_globs.ova_xml_filename + Tar.Header.make ~mod_time:now Xapi_globs.ova_xml_filename (Int64.of_int @@ String.length ova_xml) in Tar_helpers.write_block hdr (fun s -> Unixext.really_write_string s ova_xml) s ; @@ -637,6 +638,7 @@ let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state let export refresh_session __context rpc session_id s vm_ref preserve_power_state = + let now = Date.now () |> Date.to_unix_time |> Int64.of_float in info "VM.export: VM = %s; preserve_power_state = '%s'" (string_of_vm ~__context vm_ref) (string_of_bool preserve_power_state) ; @@ -646,7 +648,7 @@ let export refresh_session __context rpc session_id s vm_ref in debug "Outputting ova.xml" ; let hdr = - Tar.Header.make Xapi_globs.ova_xml_filename + Tar.Header.make ~mod_time:now Xapi_globs.ova_xml_filename (Int64.of_int @@ String.length ova_xml) in Tar_helpers.write_block hdr (fun s -> Unixext.really_write_string s ova_xml) s ;