CA-384483: Can't export VDI to VHD file with base VDI

With *hybrid source format in export, the following cases are supported:
1. nbdhybrid: QCOW2 -> NBD device in dom0 -> exported file
2. nbdhybrid: VHD -> NBD device in dom0 -> exported file
3. hybrid: VHD -> blktap device in dom0 -> exported file

The case 2 above can't support an optional parameter "base".
This parameter holds the ID of another VHD VDI. When it is passed, the
export will only write the differences between "source" and "base" to
the destination file.

As a short-term solution, in case 2 above, when the "base" is passed,
the source format is changed to "hybrid" in this commit.
This can work because:
1. the comparsion on blocks required by "base" is supported by "hybrid";
2. the raw data from NBD device and blktap (Frankentap) device are same;
3. the sparseness information of the source required in case 2 can be
   get by either NBD interface (nbdhybrid) or VHD parsing (hybrid).

Signed-off-by: Ming Lu <[email protected]>

ocaml/xapi/stream_vdi.ml

@@ -163,6 +163,31 @@ let get_nbd_device path =
   else
     None
 
+(* Copied from vhd-tool/src/image.ml.
+ * Just keep the situation of xapi doesn't depend on vhd-tool OCaml module.
+ *)
+let image_behind_nbd_device = function
+  | Some (path, _exportname) as image ->
+      (* The nbd server path exposed by tapdisk can lead us to the actual image
+         file below. Following the symlink gives a path like
+            `/run/blktap-control/nbd<pid>.<minor>`,
+         containing the tapdisk pid and minor number. Using this information,
+         we can get the file path from tap-ctl.
+      *)
+      let default _ _ = image in
+      let filename = Unix.realpath path |> Filename.basename in
+      Scanf.ksscanf filename default "nbd%d.%d" (fun pid minor ->
+          match Tapctl.find (Tapctl.create ()) ~pid ~minor with
+          | _, _, Some ("vhd", vhd) ->
+              Some ("vhd", vhd)
+          | _, _, Some ("aio", vhd) ->
+              Some ("raw", vhd)
+          | _, _, _ | (exception _) ->
+              None
+      )
+  | _ ->
+      None
+
 type extent = {flags: int32; length: int64} [@@deriving rpc]
 
 type extent_list = extent list [@@deriving rpc]

ocaml/xapi/vhd_tool_wrapper.ml

@@ -170,9 +170,16 @@ let vhd_of_device path =
       | _, _, _ ->
           raise Not_found
     with
-    | Tapctl.Not_blktap ->
+    | Tapctl.Not_blktap -> (
         debug "Device %s is not controlled by blktap" path ;
-        None
+        (* Check if it is a VHD behind a NBD deivce *)
+        Stream_vdi.(get_nbd_device path |> image_behind_nbd_device) |> function
+        | Some ("vhd", vhd) ->
+            debug "%s is a VHD behind NBD device %s" vhd path ;
+            Some vhd
+        | _ ->
+            None
+      )
     | Tapctl.Not_a_device ->
         debug "%s is not a device" path ;
         None
@@ -186,15 +193,18 @@ let send progress_cb ?relative_to (protocol : string) (dest_format : string)
     (s : Unix.file_descr) (path : string) (size : Int64.t) (prefix : string) =
   let s' = Uuidx.(to_string (make ())) in
   let source_format, source =
-    match (Stream_vdi.get_nbd_device path, vhd_of_device path) with
-    | Some (nbd_server, exportname), _ ->
+    match (Stream_vdi.get_nbd_device path, vhd_of_device path, relative_to) with
+    | Some (nbd_server, exportname), _, None ->
         ( "nbdhybrid"
         , Printf.sprintf "%s:%s:%s:%Ld" path nbd_server exportname size
         )
-    | None, Some vhd ->
+    | Some _, Some vhd, Some _ | None, Some vhd, _ ->
         ("hybrid", path ^ ":" ^ vhd)
-    | None, None ->
+    | None, None, None ->
         ("raw", path)
+    | _, None, Some _ ->
+        let msg = "Cannot compute differences on non-VHD images" in
+        error "%s" msg ; failwith msg
   in
   let relative_to =
     match relative_to with