vhd_qcow_parsing: Parse the new interval-based data_clusters format

This requires switching stream_vdi to the new format, away from the
memory-costly Map storing information on every single allocated cluster.

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

Author: last-genius

ocaml/xapi/qcow_tool_wrapper.mli

@@ -24,4 +24,4 @@ val send :
   -> int64
   -> unit
 
-val parse_header : string -> int * int list
+val parse_header : string -> int * (int * int) list

ocaml/xapi/stream_vdi.ml

@@ -195,23 +195,6 @@ let get_chunk_numbers_in_increasing_order descriptor_list offset =
   let chunks = process [] offset descriptor_list in
   List.rev chunks
 
-let get_allocated_chunks_from_clusters cluster_size cluster_list =
-  let chunk_size = Int64.to_int chunk_size in
-  let chunks_in_cluster = (cluster_size + chunk_size - 1) / chunk_size in
-  let set =
-    List.fold_left
-      (fun set cluster_no ->
-        let cluster_offset = cluster_no * cluster_size in
-        let chunk_no = cluster_offset / chunk_size in
-        let chunks_to_add =
-          Seq.init chunks_in_cluster (fun i -> chunk_no + i)
-        in
-        ChunkSet.add_seq chunks_to_add set
-      )
-      ChunkSet.empty cluster_list
-  in
-  set
-
 let send_one ofd (__context : Context.t) rpc session_id progress refresh_session
     (prefix, vdi_ref, _size) =
   let size = Db.VDI.get_virtual_size ~__context ~self:vdi_ref in
@@ -317,26 +300,47 @@ let send_one ofd (__context : Context.t) rpc session_id progress refresh_session
                 | _ ->
                     failwith (Printf.sprintf "%s: unreachable" __FUNCTION__)
               in
-              let set =
-                get_allocated_chunks_from_clusters cluster_size cluster_list
-              in
               (* First and last chunks are always written - it's a limitation
                  of the XVA format *)
               let last_chunk =
                 Int64.((to_int size - to_int chunk_size + 1) / to_int chunk_size)
               in
-              let set = set |> ChunkSet.add 0 |> ChunkSet.add last_chunk in
-              ChunkSet.iter
-                (fun this_chunk_no ->
-                  let offset = Int64.(mul (of_int this_chunk_no) chunk_size) in
+              let process_chunk chunk_no ~force =
+                if force || (chunk_no <> 0 && chunk_no <> last_chunk) then
+                  let offset = Int64.(mul (of_int chunk_no) chunk_size) in
                   let _ =
-                    write_chunk this_chunk_no offset
+                    write_chunk chunk_no offset
                       ~write_check:(fun _ _ -> true)
                       ~seek:true ~timeout_workaround:false
                   in
                   ()
+              in
+
+              process_chunk 0 ~force:true ;
+
+              let chunk_size = Int64.to_int chunk_size in
+              let chunks_in_cluster =
+                (cluster_size + chunk_size - 1) / chunk_size
+              in
+              (* Iterate over allocated intervals, copying every cluster inside *)
+              List.iter
+                (fun (cluster_no_left, cluster_no_right) ->
+                  let calc_chunk cluster =
+                    let cluster_offset = cluster * cluster_size in
+                    let chunk_no = cluster_offset / chunk_size in
+                    chunk_no
+                  in
+                  let left_chunk_no = calc_chunk cluster_no_left in
+                  let right_chunk_no =
+                    calc_chunk cluster_no_right + chunks_in_cluster - 1
+                  in
+                  for i = left_chunk_no to right_chunk_no do
+                    process_chunk i ~force:false
+                  done
                 )
-                set
+                cluster_list ;
+
+              process_chunk last_chunk ~force:true
             with e ->
               debug "%s: Falling back to reading the whole raw disk after %s"
                 __FUNCTION__ (Printexc.to_string e) ;

ocaml/xapi/vhd_qcow_parsing.ml

@@ -53,6 +53,16 @@ let parse_header pipe_reader =
     1 lsl Yojson.Basic.Util.(member "cluster_bits" json |> to_int)
   in
   let cluster_list =
-    Yojson.Basic.Util.(member "data_clusters" json |> to_list |> List.map to_int)
+    Yojson.Basic.Util.(
+      member "data_clusters" json
+      |> to_list
+      |> List.map (fun x ->
+          match to_list x with
+          | x :: y :: _ ->
+              (to_int x, to_int y)
+          | _ ->
+              raise (Invalid_argument "Invalid JSON")
+      )
+    )
   in
   (cluster_size, cluster_list)

ocaml/xapi/vhd_qcow_parsing.mli

@@ -21,4 +21,4 @@ val run_tool :
   -> string list
   -> unit
 
-val parse_header : Unix.file_descr -> int * int list
+val parse_header : Unix.file_descr -> int * (int * int) list