forked from xapi-project/xen-api
-
Notifications
You must be signed in to change notification settings - Fork 0
/
import.ml
132 lines (115 loc) · 4.76 KB
/
import.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
(*
* Copyright (C) 2006-2009 Citrix Systems Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
(*
* CLI support for stand-alone VM import command which can handle XVA directories
* (the export format of Zurich)
*)
open Stringext
open Xml
type classification =
| Zurich (** directory-style XVA produced by Zurich *)
| TarXVA (** new single-file XVA produced by this codebase *)
| Unknown
let classify path =
try
match (Unix.LargeFile.stat path).Unix.LargeFile.st_kind with
| Unix.S_REG -> TarXVA
| Unix.S_DIR ->
let xml = path ^ "/" ^ Xva.xml_filename in
begin
try
Unix.access xml [ Unix.F_OK ];
Zurich
with Unix.Unix_error _ -> Unknown
end
| _ -> Unknown
with Unix.Unix_error _ as e ->
debug(Printf.sprintf "Failed to stat: %s" path);
raise e
(** Stream a string into a tar, with a valid header and padding *)
let stream_file_from_string oc file_name body =
let hdr = Tar.Header.make file_name (Int32.of_int (String.length body)) in
output_string oc (Tar.Header.marshal hdr);
output_string oc body;
output_string oc (Tar.Header.zero_padding hdr)
let end_stream oc =
(* Add two empty blocks *)
output_string oc Tar.Header.zero_block;
output_string oc Tar.Header.zero_block;
flush oc
(** Upload a Zurich-format XVA directory *)
let stream_from_xva_dir dir oc =
let xml = Xml.parse_file (dir ^ "/" ^ Xva.xml_filename) in
stream_file_from_string oc Xva.xml_filename (Xml.to_string xml);
let vms, vdis = Xva.of_xml xml in
List.iter (fun vdi ->
if vdi.Xva.ty <> "dir-gzipped-chunks"
then failwith (Printf.sprintf "Cannot handle directory XVA disk encoding: %s" vdi.Xva.ty);
let prefix = "file://" in
if not(String.startswith prefix vdi.Xva.source)
then failwith (Printf.sprintf "Cannot handle disk source: %s (need a file:// URI)" vdi.Xva.source);
let suffix = String.sub vdi.Xva.source (String.length prefix) (String.length vdi.Xva.source - (String.length prefix)) in
let vdi_dir = dir ^ "/" ^ suffix in
let chunks = List.filter (String.startswith "chunk-") (Array.to_list (Sys.readdir vdi_dir)) in
if List.length chunks = 0 then failwith (Printf.sprintf "Failed to find disk chunks in dir: %s" vdi_dir);
(** Uncompress and stream each of the chunks in series *)
let so_far = ref 0L in
let total = vdi.Xva.size in
let remaining_this_chunk = ref 0L in
let chunks = List.sort compare chunks in
let chunk_number = ref 0 in
(** Construct a new header, add any necessary zero-padding for the previous header
and send the new header if size <> 0 *)
let make_hdr =
let last_hdr = ref None in
fun size ->
begin match !last_hdr with
| Some hdr -> output_string oc (Tar.Header.zero_padding hdr)
| None -> ()
end;
let hdr = Tar.Header.make
(Printf.sprintf "%s/%08d" vdi.Xva.vdi_name !chunk_number)
(Int64.to_int32 size) in
incr chunk_number;
last_hdr := Some hdr;
if size <> 0L
then output_string oc (Tar.Header.marshal hdr) in
List.iter (fun chunk ->
(** Uncompress and stream each of the chunks in series *)
let file = vdi_dir ^ "/" ^ chunk in
let ic = Unix.open_process_in ("zcat " ^ file) in
let finished = ref false in
while not(!finished) do
if !remaining_this_chunk = 0L then begin
remaining_this_chunk := min (Int64.sub total !so_far) 1000000L;
make_hdr !remaining_this_chunk;
end;
let bytes : int64 = Unix.copy_file ~limit:(Some !remaining_this_chunk) ic oc in
finished := bytes < !remaining_this_chunk || bytes = 0L;
remaining_this_chunk := Int64.sub !remaining_this_chunk bytes;
so_far := Int64.add !so_far bytes;
done;
close_in ic) (List.sort compare chunks);
if !so_far <> total
then failwith (Printf.sprintf "Streamed all the disk chunks I could find but I count only %s bytes out of %s"
(Int64.to_string !so_far) (Int64.to_string total))
) vdis;
end_stream oc
(** Upload from a single file XVA *)
let stream_from_xva_file file oc =
let ic = open_in_bin file in
let bytes = Unix.copy_file ic oc in
close_in ic;
end_stream oc;
debug(Printf.sprintf "Finished streaming %s bytes" (Int64.to_string bytes))