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

@@ -85,10 +85,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
@@ -101,7 +107,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/vhd_tool_wrapper.ml

@@ -150,41 +150,62 @@ let find_backend_device path =
         raise Not_found
   with _ -> None
 
+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_file_of_device path] returns (Some backing_file) where 'backing_file'
     is the leaf backing a particular device [path] (with a driver of type
     [driver] or None. [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 path ~driver =
   let tapdisk_of_path path =
-    try
-      match Tapctl.of_device (Tapctl.create ()) path with
-      | _, _, Some (typ, backing_file) when typ = driver ->
-          Some backing_file
-      | _, _, _ ->
-          raise Not_found
-    with
-    | Tapctl.Not_blktap -> (
+    match Tapctl.of_device (Tapctl.create ()) path with
+    | _, _, Some (typ, backing_file) when typ = driver ->
+        Ok backing_file
+    | _, _, Some (typ, _) ->
+        Error (Driver_mismatch {expected= driver; actual= Some typ})
+    | _, _, None ->
+        Error (Driver_mismatch {expected= driver; actual= None})
+    | exception Tapctl.Not_blktap -> (
         debug "Device %s is not controlled by blktap" path ;
         (* Check if it is a [driver] behind a NBD device *)
         Stream_vdi.(get_nbd_device path |> image_behind_nbd_device) |> function
         | Some (typ, backing_file) when typ = driver ->
             debug "%s is a %s behind NBD device %s" backing_file driver path ;
-            Some backing_file
-        | _ ->
-            None
+            Ok backing_file
+        | Some (typ, _) ->
+            Error (Driver_mismatch {expected= driver; actual= Some typ})
+        | None ->
+            Error (Driver_mismatch {expected= driver; actual= None})
       )
-    | Tapctl.Not_a_device ->
+    | exception Tapctl.Not_a_device ->
         debug "%s is not a device" path ;
-        None
-    | _ ->
+        Error Not_a_device
+    | exception Not_found ->
         debug "Device %s has an unknown driver" path ;
-        None
+        Error (Driver_unknown {path})
+    | exception (Unix.Unix_error _ as e) ->
+        debug "Could not read device %s: %s" path (Printexc.to_string e) ;
+        Error (Driver_unknown {path})
   in
   find_backend_device path |> Option.value ~default:path |> tapdisk_of_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 = backing_file_of_device ~driver:"vhd" in
   let s' = Uuidx.(to_string (make ())) in
   let source_format, source =
@@ -193,26 +214,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 = 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 =
     [