libs: add Stat module in Unixext to handle special device IDs

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,141 @@
+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 lsl 32) - 1 in
+    let major_max = (1 lsl 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 higher-most 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/unixext.ml

@@ -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.mli

@@ -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 [st_dev] into a 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] encode device into a single integer, using glibc's
+      [makedev] macro *)
+end

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

@@ -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/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 ())
@@ -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/vhd-tool/cli/dune

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

ocaml/vhd-tool/cli/sparse_dd.ml

@@ -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/src/image.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]

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/stream_vdi.ml

@@ -132,13 +132,11 @@ let write_block ~__context filename buffer ofd len =
       raise e
 
 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) |> Unixext.Stat.decode_st_dev
 
 let is_nbd_device path =
   let nbd_device_num = 43 in
-  let major, _ = get_device_numbers path in
+  let Unixext.Stat.{major; _} = get_device_numbers path in
   major = nbd_device_num
 
 type nbd_connect_info = {path: string; exportname: string} [@@deriving rpc]