CP-47001 Introduce file descriptor testing framework

.github/workflows/ocaml-ci.yml

@@ -9,7 +9,7 @@ jobs:
     name: Ocaml tests
     runs-on: ubuntu-20.04
     env:
-      package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck"
+      package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-fdcaps xapi-fd-test"
 
     steps:
       - name: Checkout code

.gitignore

@@ -1,3 +1,4 @@
 _build/
+_coverage/
 *.install
 .merlin

Makefile

@@ -1,10 +1,15 @@
 PROFILE=release
 
-.PHONY: build install uninstall clean test doc format
+.PHONY: build install uninstall clean test doc format coverage
 
 build:
 	dune build @install --profile=$(PROFILE)
 
+coverage:
+	dune runtest --instrument-with bisect_ppx --force
+	bisect-ppx-report html
+	bisect-ppx-report summary --per-file
+
 install:
 	dune install
 

dune-project

@@ -2,6 +2,8 @@
 (formatting (enabled_for ocaml))
 (name xapi-stdext)
 
+(cram enable)
+(implicit_transitive_deps false)
 (generate_opam_files true)
 
 (source (github xapi-project/stdext))
@@ -21,6 +23,8 @@
     (xapi-stdext-threads (= :version))
     (xapi-stdext-unix (= :version))
     (xapi-stdext-zerocheck (= :version))
+    (xapi-fdcaps (= :version))
+    (xapi-fdcaps-test (and (= :version) :with-test))
   )
 )
 
@@ -104,3 +108,27 @@
     (odoc :with-doc)
   )
 )
+
+(package
+  (name xapi-fdcaps)
+  (synopsis "Static capabilities for file descriptor operations")
+  (depends
+    (alcotest :with-test)
+    base-unix
+    fmt
+    (bisect_ppx :build)
+  )
+)
+
+(package
+  (name xapi-fd-test)
+  (synopsis "Test framework for file descriptor operations")
+  (depends
+    (alcotest :with-test)
+    base-unix
+    fmt
+    (mtime (>= 2.0.0))
+    logs
+    (qcheck-core (>= 0.21.2))
+  )
+)

lib/xapi-fd-test/dune

@@ -0,0 +1,6 @@
+; This will be used to test stdext itself, so do not depend on stdext here
+(library
+	(public_name xapi-fd-test)
+	(name xapi_fd_test)
+	(libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os)
+)

lib/xapi-fd-test/test/dune

@@ -0,0 +1,6 @@
+; This is a test framework, but we still need to test it
+(test
+	(package xapi-fd-test)
+	(name test_xapi_fd_test)
+	(libraries xapi_fd_test alcotest)
+)

lib/xapi-fdcaps/dune

@@ -0,0 +1,11 @@
+; Keep dependencies minimal here, ideally just OCaml stdlib
+; This will be used to test other functions in stdext, so it should not itself rely on other stdext libs!
+(library
+	(public_name xapi-fdcaps)
+	(name xapi_fdcaps)
+	(libraries fmt unix threads.posix)
+	(flags (:standard -principal))
+
+	; off by default, enable with --instrument-with bisect_ppx
+	(instrumentation (backend bisect_ppx))
+)

lib/xapi-fdcaps/properties.ml

@@ -0,0 +1,123 @@
+(*
+ * Copyright (C) 2023 Cloud Software Group
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type (+!'a, +!'b) props = {rw: 'a; kind: 'b}
+
+type rdonly = [`rdonly]
+
+type wronly = [`wronly]
+
+type rdwr = [`rdwr]
+
+let pp_rw fmt =
+  Fmt.of_to_string
+    (function #rdonly -> "RDONLY" | #wronly -> "WRONLY" | #rdwr -> "RDWR")
+    fmt
+
+type reg = [`reg]
+
+type blk = [`blk]
+
+type chr = [`chr]
+
+type dir = [`dir]
+
+type lnk = [`lnk]
+
+type fifo = [`fifo]
+
+type sock = [`sock]
+
+type kind = [reg | blk | chr | dir | lnk | fifo | sock]
+
+let to_unix_kind =
+  let open Unix in
+  function
+  | #reg ->
+      S_REG
+  | #blk ->
+      S_BLK
+  | #chr ->
+      S_CHR
+  | #dir ->
+      S_DIR
+  | #lnk ->
+      S_LNK
+  | #fifo ->
+      S_FIFO
+  | #sock ->
+      S_SOCK
+
+let pp_kind fmt =
+  Fmt.using to_unix_kind Safefd.pp_kind fmt
+
+let pp fmt =
+  Fmt.(
+    record
+      ~sep:Fmt.(any ", ")
+      [field "rw" (fun t -> t.rw) pp_rw; field "kind" (fun t -> t.kind) pp_kind]
+  )
+    fmt
+
+type readable = [rdonly | rdwr]
+
+type writable = [wronly | rdwr]
+
+type rw = [rdonly | wronly | rdwr]
+
+type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props
+
+let as_readable ({rw= #readable; _} as t) = t
+
+let as_writable ({rw= #writable; _} as t) = t
+
+let as_readable_opt = function
+  | {rw= #readable; _} as x ->
+      Some x
+  | {rw= #wronly; _} ->
+      None
+
+let as_writable_opt = function
+  | {rw= #writable; _} as x ->
+      Some x
+  | {rw= #rdonly; _} ->
+      None
+
+type espipe = [fifo | sock]
+
+let as_kind_opt expected ({kind; _} as t) =
+  (* we cannot compare the values directly because we want to keep the type parameters distinct *)
+  match (kind, expected) with
+  | #reg, #reg ->
+      Some {t with kind= expected}
+  | #blk, #blk ->
+      Some {t with kind= expected}
+  | #chr, #chr ->
+      Some {t with kind= expected}
+  | #dir, #dir ->
+      Some {t with kind= expected}
+  | #lnk, #lnk ->
+      Some {t with kind= expected}
+  | #fifo, #fifo ->
+      Some {t with kind= expected}
+  | #sock, #sock ->
+      Some {t with kind= expected}
+  | #kind, #kind ->
+      None
+
+type seekable = [reg | blk]
+
+type truncatable = reg
+
+let make rw kind = {rw; kind}