# HG changeset patch
# User David Scott <dave.scott@xxxxxxxxxxxxx>
# Date 1279121801 -3600
# Node ID aeb326b8d2d1bb5ff897ffb249ec2dbdaa1c5783
# Parent a9d00d9121a37d036aacc0defa09d490d0fc6191
Add optional compression to VM exports. Both compressed and uncompressed
formats can be imported as normal since the format is auto-detected.
Design notes on the wiki:
http://wiki.xensource.com/xenwiki/Compressing_VM_exports
Signed-off-by: David Scott <dave.scott@xxxxxxxxxxxxx>
diff -r a9d00d9121a3 -r aeb326b8d2d1 ocaml/idl/constants.ml
--- a/ocaml/idl/constants.ml Mon Jul 12 08:32:58 2010 +0100
+++ b/ocaml/idl/constants.ml Wed Jul 14 16:36:41 2010 +0100
@@ -47,6 +47,8 @@
let wlb_diagnostics_uri = "/wlb_diagnostics" (*
ocaml/xapi/wlb_reports.ml *)
let audit_log_uri = "/audit_log" (* ocaml/xapi/audit.ml *)
+let use_compression = "use_compression"
+
(* If VM.HVM_boot_policy is set to this then we boot using qemu-dm *)
let hvm_boot_policy_bios_order = "BIOS order"
(* Key we expect to find in VM.HVM_boot_params if VM.HVM_boot_policy =
BIOS_order.
diff -r a9d00d9121a3 -r aeb326b8d2d1 ocaml/xapi/cli_frontend.ml
--- a/ocaml/xapi/cli_frontend.ml Mon Jul 12 08:32:58 2010 +0100
+++ b/ocaml/xapi/cli_frontend.ml Wed Jul 14 16:36:41 2010 +0100
@@ -1231,7 +1231,7 @@
"vm-export",
{
reqd=["filename"];
- optn=["preserve-power-state"];
+ optn=["preserve-power-state"; "compress"];
help="Export a VM to <filename>.";
implementation= With_fd Cli_operations.vm_export;
flags=[Standard; Vm_selectors];
diff -r a9d00d9121a3 -r aeb326b8d2d1 ocaml/xapi/cli_operations.ml
--- a/ocaml/xapi/cli_operations.ml Mon Jul 12 08:32:58 2010 +0100
+++ b/ocaml/xapi/cli_operations.ml Wed Jul 14 16:36:41 2010 +0100
@@ -3067,7 +3067,7 @@
raise (Cli_util.Cli_failure "Need one of: vm-uuid, host-uuid,
network-uuid, sr-uuid or pool-uuid")
-let export_common fd printer rpc session_id params filename num
preserve_power_state vm =
+let export_common fd printer rpc session_id params filename num
use_compression preserve_power_state vm =
let vm_record = vm.record () in
let exporttask = Client.Task.create rpc session_id (Printf.sprintf "Export
of VM: %s" (vm_record.API.vM_uuid)) "" in
@@ -3082,13 +3082,15 @@
let f = if !num > 1 then filename ^ (string_of_int !num) else filename in
download_file ~__context rpc session_id exporttask fd f
(Printf.sprintf
- "%s?session_id=%s&task_id=%s&ref=%s&preserve_power_state=%b"
+ "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b"
(if List.mem_assoc "metadata" params
then Constants.export_metadata_uri
else Constants.export_uri)
(Ref.string_of session_id)
(Ref.string_of exporttask)
(Ref.string_of (vm.getref ()))
+ Constants.use_compression
+ (if use_compression then "true" else "false")
preserve_power_state)
"Export";
num := !num + 1)
@@ -3096,20 +3098,22 @@
let vm_export fd printer rpc session_id params =
let filename = List.assoc "filename" params in
+ let use_compression = List.mem_assoc "compress" params && (List.assoc
"compress" params = "true") in
let preserve_power_state = List.mem_assoc "preserve-power-state" params &&
bool_of_string "preserve-power-state" (List.assoc "preserve-power-state"
params) in
let num = ref 1 in
let op vm =
- export_common fd printer rpc session_id params filename num
preserve_power_state vm
+ export_common fd printer rpc session_id params filename num
use_compression preserve_power_state vm
in
- ignore(do_vm_op printer rpc session_id op params ["filename"; "metadata";
"preserve-power-state"])
+ ignore(do_vm_op printer rpc session_id op params ["filename"; "metadata";
"compress"; "preserve-power-state"])
let vm_export_aux obj_type fd printer rpc session_id params =
let filename = List.assoc "filename" params in
+ let use_compression = List.mem_assoc "compress" params && (List.assoc
"compress" params = "true") in
let preserve_power_state = List.mem_assoc "preserve-power-state" params &&
bool_of_string "preserve-power-state" (List.assoc "preserve-power-state"
params) 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
- export_common fd printer rpc session_id params filename num
preserve_power_state (vm_record rpc session_id ref)
+ export_common fd printer rpc session_id params filename num use_compression
preserve_power_state (vm_record rpc session_id ref)
let vm_copy_bios_strings printer rpc session_id params =
let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid"
params) in
diff -r a9d00d9121a3 -r aeb326b8d2d1 ocaml/xapi/export.ml
--- a/ocaml/xapi/export.ml Mon Jul 12 08:32:58 2010 +0100
+++ b/ocaml/xapi/export.ml Wed Jul 14 16:36:41 2010 +0100
@@ -419,6 +419,8 @@
Xapi_http.assert_credentials_ok "VM.export" ~http_action:"get_export" req;
+ let use_compression = List.mem_assoc Constants.use_compression req.query &&
List.assoc Constants.use_compression req.query = "true" in
+ debug "Using compression: %b" use_compression;
(* Perform the SR reachability check using a fresh context/task because
we don't want to complete the task in the forwarding case *)
@@ -485,7 +487,11 @@
with_vm_locked ~__context ~vm:vm_ref ~task_id `export
(fun () ->
Http_svr.headers s headers;
- export refresh_session __context rpc session_id s vm_ref
preserve_power_state)
+ let go fd = export refresh_session __context rpc session_id
fd vm_ref preserve_power_state in
+ if use_compression
+ then Gzip.compress s go
+ else go s
+ )
(* Exceptions are handled by Server_helpers.with_context *)
))
diff -r a9d00d9121a3 -r aeb326b8d2d1 ocaml/xapi/import.ml
--- a/ocaml/xapi/import.ml Mon Jul 12 08:32:58 2010 +0100
+++ b/ocaml/xapi/import.ml Wed Jul 14 16:36:41 2010 +0100
@@ -576,17 +576,66 @@
end;
raise e
-(** Read the next file from the tar stream as XML metadata *)
-let get_xml fd filename =
- (* Read the xml header *)
- let xml = Tar.Archive.with_next_file fd
- (fun s hdr ->
- if hdr.Tar.Header.file_name <> filename then raise (IFailure
(Unexpected_file (filename, hdr.Tar.Header.file_name)));
- let file_size = hdr.Tar.Header.file_size in
- let xml_string = Bigbuffer.make () in
- really_read_bigbuffer s xml_string file_size;
- xml_string) in
- Xml.parse_bigbuffer xml
+(** Read the next file in the archive as xml *)
+let read_xml hdr fd =
+ let xml_string = Bigbuffer.make () in
+ really_read_bigbuffer fd xml_string hdr.Tar.Header.file_size;
+ Xml.parse_bigbuffer xml_string
+
+let assert_filename_is hdr filename =
+ if hdr.Tar.Header.file_name <> filename then begin
+ let hex = Tar.Header.to_hex in
+ error "import expects the next file in the stream to be [%s]; got [%s]"
+ (hex hdr.Tar.Header.file_name) (hex Xva.xml_filename);
+ raise (IFailure (Unexpected_file(hdr.Tar.Header.file_name,
Xva.xml_filename)))
+ end
+
+(** Takes an fd and a function, tries first to read the first tar block
+ and checks for the existence of 'ova.xml'. If that fails then pipe
+ the lot through gzip and try again *)
+let with_open_archive fd f =
+ (* Read the first header's worth into a buffer *)
+ let buffer = String.make Tar.Header.length ' ' in
+ let retry_with_gzip = ref true in
+ try
+ really_read fd buffer 0 Tar.Header.length;
+
+ (* we assume the first block is not all zeroes *)
+ let Some hdr = Tar.Header.unmarshal buffer in
+ assert_filename_is hdr Xva.xml_filename;
+
+ (* successfully opened uncompressed stream *)
+ retry_with_gzip := false;
+ let xml = read_xml hdr fd in
+ Tar.Archive.skip fd (Tar.Header.compute_zero_padding_length hdr);
+ f xml fd
+ with e ->
+ if not(!retry_with_gzip) then raise e;
+ debug "Failed to directly open the archive; trying gzip";
+ let pipe_out, pipe_in = Unix.pipe () in
+ let t = Thread.create
+ (Gzip.decompress pipe_in)
+ (fun compressed_in ->
+ (* Write the initial buffer *)
+ Unix.set_close_on_exec compressed_in;
+ debug "Writing initial buffer";
+ Unix.write compressed_in buffer 0 Tar.Header.length;
+ let n = Unixext.copy_file fd compressed_in in
+ debug "Written a total of %d + %Ld bytes" Tar.Header.length n;
+ ) in
+ finally
+ (fun () ->
+ let hdr = Tar.Header.get_next_header pipe_out in
+ assert_filename_is hdr Xva.xml_filename;
+
+ let xml = read_xml hdr pipe_out in
+ Tar.Archive.skip pipe_out (Tar.Header.compute_zero_padding_length hdr);
+ f xml pipe_out)
+ (fun () ->
+ debug "Closing pipes";
+ Unix.close pipe_in;
+ Unix.close pipe_out;
+ Thread.join t)
(** Remove "import" from the current operations of all created VMs, complete
the
task including the VM references *)
@@ -622,7 +671,9 @@
[ Http.task_id_hdr ^ ":" ^ (Ref.string_of (Context.get_task_id
__context));
content_type ] in
Http_svr.headers s headers;
- let metadata = get_xml s Xva.xml_filename in
+ with_open_archive s
+ (fun metadata s ->
+ debug "Got XML";
(* Skip trailing two zero blocks *)
Tar.Archive.skip s (Tar.Header.length * 2);
@@ -651,7 +702,7 @@
cleanup on_cleanup_stack;
end;
raise e
- ))
+ )))
let handler (req: request) s =
req.close <- true;
@@ -730,8 +781,9 @@
content_type ] in
Http_svr.headers s headers;
debug "Reading XML";
- let metadata = get_xml s Xva.xml_filename in
- debug "Got XML";
+ with_open_archive s
+ (fun metadata s ->
+ debug "Got XML";
let old_zurich_or_geneva = try ignore(Xva.of_xml metadata);
true with _ -> false in
let vmrefs =
if old_zurich_or_geneva
@@ -769,7 +821,8 @@
(* against the table here. Nb. Rio GA-Miami B2
exports get their checksums checked twice! *)
if header.version.export_vsn < 2 then
begin
- let expected_checksums = checksum_table_of_xmlrpc
(get_xml s Xva.checksum_filename) in
+ let xml = Tar.Archive.with_next_file s (fun s hdr
-> read_xml hdr s) in
+ let expected_checksums = checksum_table_of_xmlrpc
xml in
if not(compare_checksums checksum_table
expected_checksums) then begin
error "Some data checksums were incorrect: VM
may be corrupt";
if not(force)
@@ -793,6 +846,7 @@
in
complete_import ~__context vmrefs;
debug "import successful"
+ )
with
| IFailure failure ->
begin
ocaml/idl/constants.ml | 2 +
ocaml/xapi/cli_frontend.ml | 2 +-
ocaml/xapi/cli_operations.ml | 14 ++++--
ocaml/xapi/export.ml | 8 +++-
ocaml/xapi/import.ml | 86 +++++++++++++++++++++++++++++++++++--------
5 files changed, 89 insertions(+), 23 deletions(-)
add-compression.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home