qcow_tool_wrapper: Read headers of QCOW2-backed VDIs on export

Pass the JSON output of read_headers into qcow2-to-stdout to handle the export
further.

Signed-off-by: Andrii Sultanov <[email protected]>

Author: last-genius

ocaml/xapi/qcow_tool_wrapper.ml

@@ -16,14 +16,15 @@ module D = Debug.Make (struct let name = __MODULE__ end)
 
 open D
 
-let run_qcow_tool qcow_tool ?input_fd ?output_fd (_progress_cb : int -> unit)
-    (args : string list) =
+let run_qcow_tool qcow_tool ?(replace_fds = []) ?input_fd ?output_fd
+    (_progress_cb : int -> unit) (args : string list) =
   info "Executing %s %s" qcow_tool (String.concat " " args) ;
   let open Forkhelpers in
   match
     with_logfile_fd "qcow-tool" (fun log_fd ->
         let pid =
-          safe_close_and_exec input_fd output_fd (Some log_fd) [] qcow_tool args
+          safe_close_and_exec input_fd output_fd (Some log_fd) replace_fds
+            qcow_tool args
         in
         let _, status = waitpid pid in
         if status <> Unix.WEXITED 0 then (
@@ -46,14 +47,56 @@ let update_task_progress (__context : Context.t) (x : int) =
 
 let receive (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
     (path : string) =
-  let args = [path] in
+  let args = ["stream_decode"; path] in
   let qcow_tool = !Xapi_globs.qcow_stream_tool in
   run_qcow_tool qcow_tool progress_cb args ~input_fd:unix_fd
 
+let read_header qcow_path =
+  let args = ["read_headers"; qcow_path] in
+  let qcow_tool = !Xapi_globs.qcow_stream_tool in
+  let pipe_reader, pipe_writer = Unix.pipe ~cloexec:true () in
+
+  let progress_cb _ = () in
+  Xapi_stdext_pervasives.Pervasiveext.finally
+    (fun () -> run_qcow_tool qcow_tool progress_cb args ~output_fd:pipe_writer)
+    (fun () -> Unix.close pipe_writer) ;
+  pipe_reader
+
 let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
     (path : string) (_size : Int64.t) =
+  let qcow_of_device =
+    Vhd_tool_wrapper.backing_file_of_device ~driver:"qcow2"
+  in
+  let qcow_path = qcow_of_device path in
+
+  (* If VDI is backed by QCOW, parse the header to determine nonzero clusters
+     to avoid reading all of the raw disk *)
+  let input_fd = Option.map read_header qcow_path in
+
+  (* Parse the header of the VDI we are diffing against as well *)
+  let relative_to_qcow_path = Option.bind relative_to qcow_of_device in
+  let diff_fd = Option.map read_header relative_to_qcow_path in
+
+  let unique_string = Uuidx.(to_string (make ())) in
   let args =
-    [path] @ match relative_to with None -> [] | Some vdi -> ["--diff"; vdi]
+    [path]
+    @ (match relative_to with None -> [] | Some vdi -> ["--diff"; vdi])
+    @ ( match relative_to_qcow_path with
+      | None ->
+          []
+      | Some _ ->
+          ["--json-header-diff"; unique_string]
+      )
+    @ match qcow_path with None -> [] | Some _ -> ["--json-header"]
   in
   let qcow_tool = !Xapi_globs.qcow_to_stdout in
-  run_qcow_tool qcow_tool progress_cb args ~output_fd:unix_fd
+  let replace_fds = Option.map (fun fd -> [(unique_string, fd)]) diff_fd in
+  Xapi_stdext_pervasives.Pervasiveext.finally
+    (fun () ->
+      run_qcow_tool qcow_tool progress_cb args ?input_fd ~output_fd:unix_fd
+        ?replace_fds
+    )
+    (fun () ->
+      Option.iter Unix.close input_fd ;
+      Option.iter Unix.close diff_fd
+    )