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 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/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 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..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,14 +5854,17 @@ 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) + 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 + ( Constants.export_metadata_uri + , Printf.sprintf "&excluded_device_types=%s" + (get_param params ~default:"" "excluded-device-types") + ) else - vm_metadata_only + (Constants.export_uri, "") in - let vm_metadata_only = get_bool_param params "metadata" in let vm_record = vm.record () in let exporttask, task_destroy_fn = match task_uuid with @@ -5884,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" - ( if vm_metadata_only then - Constants.export_metadata_uri - else - Constants.export_uri - ) - (Ref.string_of session_id) (Ref.string_of exporttask) + "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b%s" + 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 + 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 @@ -5939,6 +5927,7 @@ let vm_export fd printer rpc session_id params = ; "compress" ; "preserve-power-state" ; "include-snapshots" + ; "excluded-device-types" ] ) @@ -5946,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 = @@ -7349,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 @@ -7918,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]) @@ -7940,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/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 49ccc7b0c57..c549fb74295 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,31 +606,31 @@ 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 = + 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 + let now = Date.now () |> Date.to_unix_time |> Int64.of_float 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 - ~include_vhd_parents ~__context ~vms + ~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 ; @@ -635,16 +638,17 @@ 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) ; 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 = - 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 ; @@ -716,35 +720,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 = @@ -771,16 +783,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 @@ -800,7 +802,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/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)) 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 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 *) diff --git a/quality-gate.sh b/quality-gate.sh index 77238f4ab93..56e53e75b56 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=318 + 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"