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

These device IDs are handled in an ad-hoc way, and none of the
implementations follow the actual linux behaviour.

The glibc-provided macros are used for the implementation, with a
pure-ocaml implementation that was useful to compare against while
implementing, which has been kept in the tests, to detect any
behavioural changes.

Because Unix.stat returns an `int` instead of an int64, the code does
not support all possible values for major supported by glibc. This
shouldn't be an issue in Linux since the device value is 32-bit wide.

Signed-off-by: Pau Ruiz Safont <pau.safont@vates.tech>

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));
+}