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 <pau.safont@vates.tech>

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,8 @@ 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 =
     [

ocaml/xapi/xapi_vdi_helpers.ml

@@ -391,41 +391,59 @@ let find_backend_device path =
         raise Not_found
   with _ -> None
 
-(** [backing_info_of_device] returns Some (driver_type, backing_file) for the
-    leaf backing a particular device [path]. *)
+type backing_file_error =
+  | Driver_mismatch of {expected: string; actual: string option}
+  | Driver_unknown of {path: string}
+  | Not_a_device
+
+let backing_file_error_to_string = function
+  | Not_a_device ->
+      "Not a device"
+  | Driver_mismatch {expected; actual= None} ->
+      Printf.sprintf "Driver mismatch {expected=%s; actual=None}" expected
+  | Driver_mismatch {expected; actual= Some actual} ->
+      Printf.sprintf "Driver mismatch {expected=%s; actual=%s}" expected actual
+  | Driver_unknown {path} ->
+      Printf.sprintf "Driver unknown {path=%s}" path
+
+(** [backing_info_of_device] returns [Ok (Some (driver_type, backing_file))]
+    for the leaf backing a particular device [path]. *)
 let backing_info_of_device path =
   let tapdisk_of_path path =
-    try
-      let ( let* ) = Option.bind in
-      let* _, _, backing_info = Tapctl.of_device (Tapctl.create ()) path in
-      backing_info
-    with
-    | Tapctl.Not_a_device ->
+    match Tapctl.of_device (Tapctl.create ()) path with
+    | Some (_, _, backing_info) ->
+        Ok backing_info
+    | None ->
+        Ok None
+    | exception Tapctl.Not_a_device ->
         debug "%s is not a device" path ;
-        None
-    | Tapctl.Not_blktap -> (
+        Error Not_a_device
+    | exception Tapctl.Not_blktap -> (
         debug "Device %s is not controlled by blktap" path ;
         (* Check if it is a [driver] behind a NBD device *)
         get_nbd_device path |> image_behind_nbd_device |> function
         | Some (typ, backing_file) as backing_info ->
             debug "%s is a %s behind NBD device %s" backing_file typ path ;
-            backing_info
+            Ok backing_info
         | _ ->
-            None
+            Ok None
       )
   in
   find_backend_device path |> Option.value ~default:path |> tapdisk_of_path
 
-(** [backing_file_of_device_with_driver path driver] returns Some backing_file
+(** [backing_file_of_device_with_driver path driver] returns [Ok backing_file]
     where [backing_file] is the leaf backing a particular device [path]
-    (with a driver of type [driver]) or None.
+    (with a driver of type [driver]) or [Error backing_file_error].
     [path] may either be a blktap2 device *or* a blkfront device backed by a
     blktap2 device. If the latter then the script must be
     run in the same domain as blkback. *)
 let backing_file_of_device_with_driver path ~driver =
   match backing_info_of_device path with
-  | Some (typ, backing_file) when typ = driver ->
-      Some backing_file
-  | _ ->
+  | Ok (Some (typ, backing_file)) when typ = driver ->
+      Ok backing_file
+  | Ok info ->
       debug "Device %s has an unknown driver" path ;
-      None
+      let typ = Option.map fst info in
+      Error (Driver_mismatch {expected= driver; actual= typ})
+  | Error _ as err ->
+      err