@@ -22,32 +22,43 @@ let receive (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
2222 Vhd_qcow_parsing. run_tool qcow_tool progress_cb args ~input_fd: unix_fd
2323
2424let read_header qcow_path =
25- let args = [" read_headers" ; qcow_path] in
26- let qcow_tool = ! Xapi_globs. qcow_stream_tool in
27- let pipe_reader, pipe_writer = Unix. pipe ~cloexec: true () in
28-
2925 let progress_cb _ = () in
30- let (_ : Thread.t ) =
26+ let run_in_thread tool args pipe_writer replace_fds =
3127 Thread. create
3228 (fun () ->
3329 Xapi_stdext_pervasives.Pervasiveext. finally
3430 (fun () ->
35- Vhd_qcow_parsing. run_tool qcow_tool progress_cb args
36- ~output_fd: pipe_writer
31+ Vhd_qcow_parsing. run_tool tool progress_cb args
32+ ~output_fd: pipe_writer ~replace_fds
3733 )
3834 (fun () -> Unix. close pipe_writer)
3935 )
4036 ()
4137 in
42- pipe_reader
38+
39+ let map_pipe_reader, map_pipe_writer = Unix. pipe ~cloexec: true () in
40+ let (_ : Thread.t ) =
41+ run_in_thread ! Xapi_globs. qemu_img
42+ [" map" ; qcow_path; " --output=json" ]
43+ map_pipe_writer []
44+ in
45+
46+ let info_pipe_reader, info_pipe_writer = Unix. pipe ~cloexec: true () in
47+ let (_ : Thread.t ) =
48+ run_in_thread ! Xapi_globs. qemu_img
49+ [" info" ; qcow_path; " --output=json" ]
50+ info_pipe_writer []
51+ in
52+
53+ (map_pipe_reader, info_pipe_reader)
4354
4455let parse_header qcow_path =
45- let pipe_reader = read_header qcow_path in
46- Vhd_qcow_parsing. parse_header pipe_reader
56+ let pipe, _ = read_header qcow_path in
57+ Vhd_qcow_parsing. parse_header pipe
4758
4859let parse_header_interval qcow_path =
49- let pipe_reader = read_header qcow_path in
50- Vhd_qcow_parsing. parse_header_interval pipe_reader
60+ let pipes = read_header qcow_path in
61+ Vhd_qcow_parsing. parse_header_qemu_img pipes
5162
5263let send ?relative_to (progress_cb : int -> unit ) (unix_fd : Unix.file_descr )
5364 (path : string ) (_size : Int64.t ) =
@@ -58,7 +69,7 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
5869
5970 (* If VDI is backed by QCOW, parse the header to determine nonzero clusters
6071 to avoid reading all of the raw disk *)
61- let input_fd = Result. map read_header qcow_path |> Result. to_option in
72+ let input_fds = Result. map read_header qcow_path |> Result. to_option in
6273
6374 (* TODO: If VHD headers are to be consulted as well, qcow2-to-stdout
6475 needs to properly account for cluster_bits. Currently QCOW2 export
@@ -73,28 +84,60 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
7384 | None ->
7485 None
7586 in
76- let diff_fd = Option. map read_header relative_to_qcow_path in
87+ let diff_fds = Option. map read_header relative_to_qcow_path in
88+
89+ let map_fd_string = Uuidx. (to_string (make () )) in
90+ let info_fd_string = Uuidx. (to_string (make () )) in
91+ let diff_map_fd_string = Uuidx. (to_string (make () )) in
92+ let diff_info_fd_string = Uuidx. (to_string (make () )) in
7793
78- let unique_string = Uuidx. (to_string (make () )) in
7994 let args =
8095 [path]
8196 @ (match relative_to with None -> [] | Some vdi -> [" --diff" ; vdi])
8297 @ ( match relative_to_qcow_path with
8398 | None ->
8499 []
85100 | Some _ ->
86- [" --json-header-diff" ; unique_string]
101+ [
102+ " --json-header-diff-map"
103+ ; diff_map_fd_string
104+ ; " --json-header-diff-info"
105+ ; diff_info_fd_string
106+ ]
87107 )
88- @ match qcow_path with Error _ -> [] | Ok _ -> [" --json-header" ]
108+ @
109+ match qcow_path with
110+ | Error _ ->
111+ []
112+ | Ok _ ->
113+ [
114+ " --json-header-map"
115+ ; map_fd_string
116+ ; " --json-header-info"
117+ ; info_fd_string
118+ ]
89119 in
90120 let qcow_tool = ! Xapi_globs. qcow_to_stdout in
91- let replace_fds = Option. map (fun fd -> [(unique_string, fd)]) diff_fd in
121+ let replace_fds =
122+ Option. map
123+ (fun (map_fd , info_fd ) ->
124+ let rfds = [(map_fd_string, map_fd); (info_fd_string, info_fd)] in
125+ match diff_fds with
126+ | Some (diff_map_fd , diff_info_fd ) ->
127+ (diff_map_fd_string, diff_map_fd)
128+ :: (diff_info_fd_string, diff_info_fd)
129+ :: rfds
130+ | None ->
131+ rfds
132+ )
133+ input_fds
134+ in
92135 Xapi_stdext_pervasives.Pervasiveext. finally
93136 (fun () ->
94- Vhd_qcow_parsing. run_tool qcow_tool progress_cb args ?input_fd
95- ~output_fd: unix_fd ?replace_fds
137+ Vhd_qcow_parsing. run_tool qcow_tool progress_cb args ~output_fd: unix_fd
138+ ?replace_fds
96139 )
97140 (fun () ->
98- Option. iter Unix. close input_fd ;
99- Option. iter Unix. close diff_fd
141+ Option. iter ( fun ( x , y ) -> Unix. close x ; Unix. close y) input_fds ;
142+ Option. iter ( fun ( x , y ) -> Unix. close x ; Unix. close y) diff_fds
100143 )
0 commit comments