vhd_tool_wrapper: generate detailed errors when getting tapctl devices

Previously, when a failure happened while getting a base vhd, a
non-descriptive error was printed. Because there can be many reasons
that can cause this code to fail, model the possible errors and print
them when needed.

Signed-off-by: Pau Ruiz Safont <[email protected]>

Author: psafont

ocaml/tapctl/tapctl.ml

@@ -507,18 +507,15 @@ let stats ctx t =
 let read_proc_devices () : (int * string) list =
   let parse_line x =
     match List.filter (fun x -> x <> "") (String.split_on_char ' ' x) with
-    | [x; y] -> (
-      try Some (int_of_string x, y) with _ -> None
-    )
+    | [x; y] ->
+        Option.bind (int_of_string_opt x) (fun x -> Some (x, y))
     | _ ->
         None
   in
-  List.concat
-    (List.map Option.to_list
-       (Unixext.file_lines_fold
-          (fun acc x -> parse_line x :: acc)
-          [] "/proc/devices"
-       )
+  List.concat_map Option.to_list
+    (Unixext.file_lines_fold
+       (fun acc x -> parse_line x :: acc)
+       [] "/proc/devices"
     )
 
 let driver_of_major major = List.assoc major (read_proc_devices ())

ocaml/xapi/qcow_tool_wrapper.ml

@@ -48,10 +48,16 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
 
   (* 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
+  let input_fd = Result.map read_header qcow_path |> Result.to_option 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 relative_to_qcow_path =
+    match relative_to with
+    | Some x ->
+        Result.to_option (qcow_of_device x)
+    | None ->
+        None
+  in
   let diff_fd = Option.map read_header relative_to_qcow_path in
 
   let unique_string = Uuidx.(to_string (make ())) in
@@ -64,7 +70,7 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
       | Some _ ->
           ["--json-header-diff"; unique_string]
       )
-    @ match qcow_path with None -> [] | Some _ -> ["--json-header"]
+    @ match qcow_path with Error _ -> [] | Ok _ -> ["--json-header"]
   in
   let qcow_tool = !Xapi_globs.qcow_to_stdout in
   let replace_fds = Option.map (fun fd -> [(unique_string, fd)]) diff_fd in

ocaml/xapi/stream_vdi.ml

@@ -304,7 +304,7 @@ let send_one ofd (__context : Context.t) rpc session_id progress refresh_session
             Xapi_vdi_helpers.backing_info_of_device dom0_path
           in
           match backing_info with
-          | Some (driver, path) when driver = "vhd" || driver = "qcow2" -> (
+          | Ok (Some (driver, path)) when driver = "vhd" || driver = "qcow2" -> (
             try
               (* Read backing file headers, then only read and write
                  allocated clusters from the bitmap *)

ocaml/xapi/vhd_tool_wrapper.ml

@@ -131,6 +131,7 @@ let parse_header vhd_path =
 
 let send progress_cb ?relative_to (protocol : string) (dest_format : string)
     (s : Unix.file_descr) (path : string) (size : Int64.t) (prefix : string) =
+  let __FUN = __FUNCTION__ in
   let vhd_of_device =
     Xapi_vdi_helpers.backing_file_of_device_with_driver ~driver:"vhd"
   in
@@ -143,26 +144,29 @@ let send progress_cb ?relative_to (protocol : string) (dest_format : string)
         ( "nbdhybrid"
         , Printf.sprintf "%s:%s:%s:%Ld" path nbd_server exportname size
         )
-    | Some _, Some vhd, Some _ | None, Some vhd, _ ->
+    | Some _, Ok vhd, Some _ | None, Ok vhd, _ ->
         ("hybrid", path ^ ":" ^ vhd)
-    | None, None, None ->
+    | None, Error _, None ->
         ("raw", path)
-    | _, None, Some _ ->
+    | _, Error _, Some _ ->
         let msg = "Cannot compute differences on non-VHD images" in
         error "%s" msg ; failwith msg
   in
   let relative_to =
-    match relative_to with
-    | Some path -> (
+    let maybe_device path =
       match vhd_of_device path with
-      | Some vhd ->
+      | Ok vhd ->
           Some vhd
-      | None ->
-          error "base VDI is not a vhd; cannot compute differences" ;
-          failwith "base VDI is not a vhd; cannot compute differences"
-    )
-    | None ->
-        None
+      | Error e ->
+          let explanation = Xapi_vdi_helpers.backing_file_error_to_string e in
+          let msg =
+            Printf.sprintf
+              "%s: base VDI is not a vhd; cannot compute differences: %s" __FUN
+              explanation
+          in
+          error "%s" msg ; failwith msg
+    in
+    Option.bind relative_to maybe_device
   in
   let args =
     [