libs: add Stat module in Unixext to handle special device IDs (#6812)

These device IDs are handled in an ad-hoc way, and none of the
implementations follow the actual linux behaviour, replace all of them
with an in imeplementation that uses the glibc macros to handle these.

Also change vhd_wrapper_tool to print better error messages when there's
an error when getting the base VHD.

Reproduction steps:

- Create a pool with 2 hosts
- SSH into one of the hosts and run `for i in $(seq 1 512) ; do tap-ctl
allocate; done`. This forces the minor device ID to be higher than 255
for the local VBD created.
- Create a guest in the local SR of the host where the previous command
was run, with the guest tools installed to support live migration.
- Live-migrate the guest between the hosts:
```
xe vm-migrate live=true uuid=ff50e9b1-c155-ed39-a2cc-680f9acaada4 host=pau-xcp-01 vdi:f613c010-7c06-4288-b0db-d1bde01fe0ef=23df0f9c-a9d8-5756-c829-e3655a225224 remote-master=pau-xcp-00 remote-username=root remote-password=xxx

Performing a storage live migration. Your VM's VDIs will be migrated with the VM.
Will migrate to remote host: pau-xcp-01, using remote network: Pool-wide network associated with eth0. Here is the VDI mapping:
VDI f613c010-7c06-4288-b0db-d1bde01fe0ef -> SR 23df0f9c-a9d8-5756-c829-e3655a225224
The server failed to handle your request, due to an internal error. The given message may give details useful for debugging the problem.
message: Storage_error ([S(Internal_error);S(Storage_error ([S(Migration_mirror_fd_failure);S(VDI Not Attached)]))])
```

The migration succeeds when both hosts in the pool have the changes in
this PR running.

Author: psafont

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune

@@ -20,6 +20,13 @@
   (action (run %{deps} -v -bt))
 )
 
+(test
+ (modes exe)
+ (name test_stat)
+ (package xapi-stdext-unix)
+ (modules test_stat)
+ (libraries alcotest fmt xapi-stdext-unix unix))
+
 (test
  (modes exe)
  (name test_systemd)

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_stat.ml

@@ -0,0 +1,142 @@
+let major_nbd = 43
+
+(** This module type helps us to implement alternative modules for [Stat].
+    In particular one that uses the previous ad-hoc functions that where
+    incorrect, and one that we can use as reference in case the behaviour
+    changes and possibly change the users of [Stat].
+  *)
+module type S = sig
+  type device
+
+  val device : major:int -> minor:int -> device option
+
+  val encode_st_dev : device -> int
+
+  val decode_st_dev : int -> device
+
+  val major : device -> int
+
+  val minor : device -> int
+
+  val pp : Format.formatter -> device -> unit
+end
+
+module Stat : S = struct
+  include Xapi_stdext_unix.Unixext.Stat
+
+  let major {major; _} = major
+
+  let minor {minor; _} = minor
+
+  let pp =
+    Fmt.(
+      record ~sep:(any ", ")
+        [
+          field "major" (fun d -> d.major) int
+        ; field "minor" (fun d -> d.minor) int
+        ]
+    )
+end
+
+module Stat_reference : S = struct
+  type device = {major: int; minor: int}
+
+  let ( << ) = Stdlib.( lsl )
+
+  let ( >> ) = Stdlib.( lsr )
+
+  let ( &^ ) = Stdlib.( land )
+
+  let ( |^ ) = Stdlib.( lor )
+
+  let device ~major ~minor =
+    (* Linux's devids are 32-bit wide and the major and minor ones are 16-bit
+       wide, but we can support well up to 32-bit-wide minors *)
+    let minor_max = (1 << 32) - 1 in
+    let major_max = (1 << 16) - 1 in
+    if major < 0 || major_max < major || minor < 0 || minor_max < minor then
+      None
+    else
+      Some {major; minor}
+
+  let encode_st_dev {major; minor} =
+    0
+    |^ (major &^ 0x00000fff << 8)
+    |^ (major &^ 0x7ffff000 << 32)
+    |^ (minor &^ 0x000000ff << 0)
+    |^ (minor &^ 0xffffff00 << 12)
+
+  let decode_st_dev dev =
+    (* follow glibc's implementation, with an exception: the most significant
+       bit is ignored because ints are 63 bits in ocaml. In any case,
+       [Unix.stat] returns a 63-bit int, so we can't do much in this code to
+       avoid this. *)
+    let major =
+      0 |^ (dev &^ 0x7ffff00000000000 >> 32) |^ (dev &^ 0x00000000000fff00 >> 8)
+    in
+    let minor =
+      0 |^ (dev &^ 0x00000ffffff00000 >> 12) |^ (dev &^ 0x00000000000000ff >> 0)
+    in
+    {major; minor}
+
+  let major {major; _} = major
+
+  let minor {minor; _} = minor
+
+  let pp =
+    Fmt.(
+      record ~sep:(any ", ")
+        [
+          field "major" (fun d -> d.major) int
+        ; field "minor" (fun d -> d.minor) int
+        ]
+    )
+end
+
+let hex = Alcotest.testable (Fmt.of_to_string (Format.sprintf "0x%x")) ( = )
+
+let current_t = Alcotest.testable Stat.pp ( = )
+
+let test_combinations f ~major:lst_a ~minor:lst_b =
+  let test a b = (Printf.sprintf "major %i, minor %i" a b, `Quick, f a b) in
+  List.concat_map (fun a -> List.map (test a) lst_b) lst_a
+
+let spec_minor = [0; 31; 65; 256; 1025; 4098; (1 lsl 32) - 1]
+
+let spec_major = [0; major_nbd; (1 lsl 16) - 1]
+
+let test_reference =
+  let test major minor () =
+    let current = Stat.device ~major ~minor |> Option.get in
+    let reference = Stat_reference.device ~major ~minor |> Option.get in
+    let encoded_cur = Stat.encode_st_dev current in
+    let encoded_ref = Stat_reference.encode_st_dev reference in
+
+    Alcotest.check hex "Encode must match reference implementation" encoded_ref
+      encoded_cur ;
+
+    let decoded_cur = Stat.decode_st_dev encoded_ref in
+    let decoded_ref = Stat_reference.decode_st_dev encoded_ref in
+
+    Alcotest.(check @@ pair int int)
+      "Decode must match reference implementation"
+      Stat_reference.(major decoded_ref, minor decoded_ref)
+      Stat.(major decoded_cur, minor decoded_cur)
+  in
+  let tests = test_combinations test ~major:spec_major ~minor:spec_minor in
+  ("Compare with reference", tests)
+
+let test_roundtrip =
+  let test major minor () =
+    let current = Stat.device ~major ~minor |> Option.get in
+    let encoded_cur = Stat.encode_st_dev current in
+
+    let decoded_cur = Stat.decode_st_dev encoded_cur in
+    Alcotest.check current_t "Roundtripped current" current decoded_cur
+  in
+  let tests = test_combinations test ~major:spec_major ~minor:spec_minor in
+  ("Roundtrip", tests)
+
+let tests = [test_reference; test_roundtrip]
+
+let () = Alcotest.run "Uniext.Stat suite" tests

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_stat.mli

@@ -1002,3 +1002,19 @@ let with_socket_timeout fd timeout_opt f =
       set_socket_timeout fd t ; Fun.protect ~finally f
   | None ->
       f ()
+
+module Stat = struct
+  type device = {major: int; minor: int}
+
+  let device ~major ~minor = Some {major; minor}
+
+  external makedev : int -> int -> int = "stub_makedev" [@@noalloc]
+
+  let encode_st_dev {major; minor} = makedev major minor
+
+  external get_major : int -> int = "stub_major" [@@noalloc]
+
+  external get_minor : int -> int = "stub_minor" [@@noalloc]
+
+  let decode_st_dev dev = {major= get_major dev; minor= get_minor dev}
+end

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml

@@ -312,3 +312,29 @@ module Daemon : sig
 
       See sd_booted(3) for more information. *)
 end
+
+module Stat : sig
+  type device = private {major: int; minor: int}
+  (* A Linux-specific device ID *)
+
+  val decode_st_dev : int -> device
+  (** [decode_st_dev st_dev] decodes the integer [st_dev] into a device, with
+      separate major and minor device IDs. *)
+
+  (**/**)
+
+  (* Testing-specific functions.
+      For more information on how device IDs are handles in linux, see
+      https://github.com/torvalds/linux/blob/ea1013c1539270e372fc99854bc6e4d94eaeff66/include/linux/kdev_t.h#L39
+      and how glibc handles them, see
+      https://elixir.bootlin.com/glibc/glibc-2.42.9000/source/bits/sysmacros.h#L37
+  *)
+
+  val device : major:int -> minor:int -> device option
+  (** [device ~major ~minor] creates a device datatype if [major] and [minor]
+      are 32-bit wide or less, or returns [None]. *)
+
+  val encode_st_dev : device -> int
+  (** [encode_st_dev device] encodes [device] into a single integer, using
+      glibc's [makedev] macro *)
+end

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli

@@ -22,6 +22,7 @@
 #include <stdio.h> /* snprintf */
 #include <sys/ioctl.h>
 #include <sys/statvfs.h>
+#include <sys/sysmacros.h> /* needed for minor and major macros */
 #if defined(__linux__)
 # include <linux/fs.h> 
 #endif
@@ -170,3 +171,33 @@ CAMLprim value stub_statvfs(value filename)
 
   CAMLreturn(v);
 }
+
+CAMLprim value stub_makedev(value majo, value mino)
+{
+  CAMLparam2(majo, mino);
+  long ret;
+
+  ret = makedev(Long_val(majo), Long_val(mino));
+          
+  CAMLreturn(Val_long(ret));
+}
+
+CAMLprim value stub_major(value dev)
+{
+  CAMLparam1(dev);
+  long ret;
+
+  ret = major(Long_val(dev));
+          
+  CAMLreturn(Val_long(ret));
+}
+
+CAMLprim value stub_minor(value dev)
+{
+  CAMLparam1(dev);
+  long ret;
+
+  ret = minor(Long_val(dev));
+          
+  CAMLreturn(Val_long(ret));
+}

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c

@@ -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 ())
@@ -529,9 +526,9 @@ exception Not_a_device
 
 let of_device ctx path =
   let stat = Unix.stat path in
+  let module Stat = Unixext.Stat in
   if stat.Unix.st_kind <> Unix.S_BLK then raise Not_a_device ;
-  let major = stat.Unix.st_rdev / 256 in
-  let minor = stat.Unix.st_rdev mod 256 in
+  let Stat.{major; minor} = Stat.decode_st_dev stat.Unix.st_rdev in
   if driver_of_major major <> "tapdev" then raise Not_blktap ;
   match List.filter (fun (tapdev, _, _) -> tapdev.minor = minor) (list ctx) with
   | [t] ->

ocaml/tapctl/tapctl.ml

@@ -19,6 +19,7 @@
     vhd-format-lwt
     xapi-idl
     xapi-log
+    xapi-stdext-unix
     xenstore_transport.unix
     ezxenstore
   )

ocaml/vhd-tool/cli/dune

@@ -213,10 +213,11 @@ let after f g =
 let find_backend_device path =
   try
     let open Ezxenstore_core.Xenstore in
+    let module Stat = Xapi_stdext_unix.Unixext.Stat in
     (* If we're looking at a xen frontend device, see if the backend
        is in the same domain. If so check if it looks like a .vhd *)
     let rdev = (Unix.LargeFile.stat path).Unix.LargeFile.st_rdev in
-    let major = rdev / 256 and minor = rdev mod 256 in
+    let Stat.{major; minor} = Stat.decode_st_dev rdev in
     let link =
       Unix.readlink (Printf.sprintf "/sys/dev/block/%d:%d/device" major minor)
     in

ocaml/vhd-tool/cli/sparse_dd.ml

@@ -1,11 +1,11 @@
+module Stat = Xapi_stdext_unix.Unixext.Stat
+
 let get_device_numbers path =
-  let rdev = (Unix.LargeFile.stat path).Unix.LargeFile.st_rdev in
-  let major = rdev / 256 and minor = rdev mod 256 in
-  (major, minor)
+  Unix.LargeFile.((stat path).st_rdev) |> Stat.decode_st_dev
 
 let is_nbd_device path =
   let nbd_device_num = 43 in
-  let major, _ = get_device_numbers path in
+  let Stat.{major; _} = get_device_numbers path in
   major = nbd_device_num
 
 type t = [`Vhd of string | `Raw of string | `Nbd of string * string]