vhd_tool_wrapper: Add parse_header to determine allocated blocks

Vhd_tool_wrapper.run_vhd_tool is hardcoded to read the progress percentage
printed by vhd-tool, so use Qcow_tool_wrapper.run_qcow_tool to run vhd-tool
since it's generic enough to allow that.

Signed-off-by: Andrii Sultanov <andriy.sultanov@vates.tech>

Author: last-genius

ocaml/xapi/qcow_tool_wrapper.ml

@@ -62,11 +62,21 @@ let read_header qcow_path =
     (fun () -> Unix.close pipe_writer) ;
   pipe_reader
 
-let parse_header qcow_path =
-  let pipe_reader = read_header qcow_path in
+let read_vhd_header path =
+  let vhd_tool = !Xapi_globs.vhd_tool in
+  let args = ["read_headers"; path] in
+  let pipe_reader, pipe_writer = Unix.pipe ~cloexec:true () in
+
+  let progress_cb _ = () in
+  Xapi_stdext_pervasives.Pervasiveext.finally
+    (fun () -> run_qcow_tool vhd_tool progress_cb args ~output_fd:pipe_writer)
+    (fun () -> Unix.close pipe_writer) ;
+  pipe_reader
+
+let parse_header pipe_reader =
   let ic = Unix.in_channel_of_descr pipe_reader in
   let buf = Buffer.create 4096 in
-  let json = Yojson.Basic.from_channel ~buf ~fname:"qcow_header.json" ic in
+  let json = Yojson.Basic.from_channel ~buf ~fname:"header.json" ic in
   In_channel.close ic ;
   let cluster_size =
     1 lsl Yojson.Basic.Util.(member "cluster_bits" json |> to_int)
@@ -76,6 +86,14 @@ let parse_header qcow_path =
   in
   (cluster_size, cluster_list)
 
+let parse_qcow_header qcow_path =
+  let pipe_reader = read_header qcow_path in
+  parse_header pipe_reader
+
+let parse_vhd_header qcow_path =
+  let pipe_reader = read_vhd_header qcow_path in
+  parse_header pipe_reader
+
 let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
     (path : string) (_size : Int64.t) =
   let qcow_of_device =

ocaml/xapi/qcow_tool_wrapper.mli

@@ -24,4 +24,6 @@ val send :
   -> int64
   -> unit
 
-val parse_header : string -> int * int list
+val parse_vhd_header : string -> int * int list
+
+val parse_qcow_header : string -> int * int list

ocaml/xapi/vhd_tool_wrapper.ml

@@ -112,6 +112,8 @@ let receive progress_cb format protocol (s : Unix.file_descr)
   in
   run_vhd_tool progress_cb args s s' path
 
+let parse_header = Qcow_tool_wrapper.parse_vhd_header
+
 let send progress_cb ?relative_to (protocol : string) (dest_format : string)
     (s : Unix.file_descr) (path : string) (size : Int64.t) (prefix : string) =
   let vhd_of_device =