CP-47001 Introduce file descriptor testing framework

dune-project

@@ -2,6 +2,7 @@
 (formatting (enabled_for ocaml))
 (name xapi-stdext)
 
+(cram enable)
 (implicit_transitive_deps false)
 (generate_opam_files true)
 

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}

lib/xapi-fdcaps/properties.mli

@@ -0,0 +1,192 @@
+(*
+ * 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.
+ *)
+
+(** Static file property checking
+
+ When file descriptors are open they have:
+ * a file kind: ({!type:reg}, {!type:blk), {!type:chr}, {!type:lnk}, {!type:fifo}, {!type:sock})
+ * an open mode: {!type:readonly}, {!type:writeonly}, {!type:readwrite} depending on the {!type:Unix.open_flag} used
+
+ Depending on these properties there are {!val:Unix} operations on file descriptors that always fail, e.g.:
+ * writing to a read-only file
+ * socket operation on non-socket
+ * seeking on a pipe
+ * ...
+
+ The read-write property can also change at runtime:
+ * {!val:Unix.shutdown} can be used to shutdown the socket in either direction
+
+ We track the property of the file at open time, and we reject operations that we can statically determine to always fail.
+ This doesn't guarantee the absence of runtime errors, but catches programming errors like accidentally swapping the read and write ends of a pipe,
+ or attempting to set a socket timeout on a pipe.
+
+ We use polymorphic variants as type parameters to track these properties: they are simple to use and work well with type inference.
+ They also allow dispatching at runtime on the actual capabilities available, although they could be purely compile-time types (phantom types).
+
+ Alternative approaches (typically with phantom types):
+ * abstract types as phantom type parameters: don't work well with type inference, and cannot express removing a property
+ * behavioural types (recursive polymorphic variants) can express removing a property, but error messages and type signatures become too long
+ * object phantom types strike a good balance between clarity of error messages and complexity of type signatures
+
+ It'd be also possible to use purely boolean properties (capabilities), but that causes a long type signature, and allows expressing meaningless combinations,
+ such as a file that is both a socket and seekable, which is impossible.
+ Instead we directly map the concepts from the Unix module to a polymorphic variant (e.g. instead of separate read and write properties we have the 3 properties from the Unix module).
+
+{b References.}
+{ul
+  {- Yaron Minsky.
+   {e {{:https://blog.janestreet.com/howto-static-access-control-using-phantom-types/}HOWTO: Static access control using phantom types}. 2008.}}
+  {- KC Sivaramakrishnan.
+   {e {{:https://kcsrk.info/ocaml/types/2016/06/30/behavioural-types/#file-descriptors}Behavioural types}. 2016.}}
+  {- Florian Angeletti.
+   {e {{:https://stackoverflow.com/a/55081337}Object phantom types}. 2019.}}
+}
+*)
+
+(** {1 File properties}
+
+ Polymorphic type parameters for the set of properties a file descriptor may have on a given codepath.
+ E.g. {[> rdonly | wronly]} means that this codepath may be reached by a file descriptor with either of these properties,
+ although of course a file descriptor can only have one of these properties at a time.
+
+ Usual rules for using polymorphic variants apply:
+ * when receiving a type declare an upper bound on what the code can handle, e.g. : {[< readable]}
+ * when returning a type declare a lower bound to make type inference/unification work, e.g. : {[> readable]}
+
+ Naming conventions:
+ * [type property ]
+ * [val as_property : [< property] t -> [> property] t]
+ * [val as_property_opt: [< all] t -> [> property] t option]
+*)
+
+(** file properties: {!type:rw}, {!type:kind}
+
+  Upper bounds are avoided here to make the type usable in functors
+ *)
+type (+!'a, +!'b) props
+
+(** {2 Read/write property}
+
+  A file can be read-only, write-only, or read-write.
+*)
+
+(** file opened with {!val:Unix.O_RDONLY} or the read end of a pipe *)
+type rdonly = [`rdonly]
+
+(** file opened with {!val:Unix.O_WRONLY} or the write end of a pipe *)
+type wronly = [`wronly]
+
+(** file opened with {!val:Unix.O_RDWR} or a socketpair *)
+type rdwr = [`rdwr]
+
+(** file opened with either {!val:Unix.O_RDONLY} or {!val:Unix.O_RDWR} *)
+type readable = [rdonly | rdwr]
+
+(** file opened with either {!val:Unix.O_WRONLY} or {!val:Unix.O_RDWR} *)
+type writable = [wronly | rdwr]
+
+(** the read-write property *)
+type rw = [rdonly | wronly | rdwr]
+
+val pp_rw : Format.formatter -> [< rw] -> unit
+(** [pp_rw formatter rw] pretty prints the [rw] state on [formatter]. *)
+
+(** {2 File kind} *)
+
+(** A regular file, {!val:Unix.S_REG} *)
+type reg = [`reg]
+
+(** A block device, {!val:Unix.S_BLK} *)
+type blk = [`blk]
+
+(** A character device, {!val:Unix.S_CHR} *)
+type chr = [`chr]
+
+(** A directory, {!val:Unix.S_DIR} *)
+type dir = [`dir]
+
+(** A symbolic link, {!val:Unix.S_LNK} *)
+type lnk = [`lnk]
+
+(** A pipe or FIFO, {!val:Unix.S_FIFO} *)
+type fifo = [`fifo]
+
+(** A socket, {!val:Unix.S_SOCK} *)
+type sock = [`sock]
+
+(** a {!type:Unix.file_kind} *)
+type kind = [reg | blk | chr | dir | lnk | fifo | sock]
+
+val pp_kind : Format.formatter -> [< kind] -> unit
+(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *)
+
+(** {2 Property type} *)
+
+(** upper bounds on properties *)
+type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props
+
+(** {2 Operations on read-write properties} *)
+
+val as_readable : ([< readable], 'a) t -> ([> readable], 'a) t
+(** [as_readable t] requires [t] to be readable and ignores the writeonly property. *)
+
+val as_writable : ([< writable], 'a) t -> ([> writable], 'a) t
+(** [as_writable t] requires [t] to be writable and ignores the readonly property. *)
+
+val as_readable_opt : ([< rw], 'a) t -> ([> readable], 'a) t option
+(** [as_readable_opt t] tests for the presence of the readable property at runtime.
+
+  @returns [Some t] when [t] is readable, and [None] otherwise
+*)
+
+val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option
+(** [as_writable_opt t] tests for the presence of the writable property at runtime.
+
+  @returns [Some t] when [t] is writable, and [None] otherwise
+*)
+
+(** {2 Operations on file kind properties} *)
+
+val to_unix_kind : kind -> Unix.file_kind
+(** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *)
+
+(** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *)
+type espipe = [fifo | sock]
+
+val as_kind_opt : ([< kind] as 'a) -> ('b, [< kind]) t -> ('b, 'a) t option
+(** [as_kind_opt kind t] checks whether [t] is of type [kind].
+
+  @returns [Some t] if [t] is of type [kind], and [None] otherwise
+ *)
+
+(** {2 Properties derived from file kind} *)
+
+(** seek may be implementation defined on devices other than regular files or block devices.
+
+  E.g. {!type:chr} devices would always return 0 when seeking, which doesn't follow the usual semantics of seek.
+*)
+type seekable = [reg | blk]
+
+(** truncate only works on regular files *)
+type truncatable = reg
+
+(** {2 Create properties} *)
+
+val make : ([< rw] as 'a) -> ([< kind] as 'b) -> ('a, 'b) t
+(** [make rw kind] builds a file property *)
+
+(** {2 Pretty printing} *)
+
+val pp : Format.formatter -> (_, _) t -> unit
+(** [pp formatter t] pretty prints the properties on [formatter]. *)

lib/xapi-fdcaps/test/dune

@@ -1,5 +1,10 @@
 (tests
 	(package xapi-fdcaps)
-	(names test_safefd)
+	(names test_safefd test_properties)
 	(libraries xapi_fdcaps alcotest fmt)
 )
+
+(cram
+	(deps (package xapi-fdcaps))
+	(enabled_if (= %{ocaml_version} 4.14.1))
+)

lib/xapi-fdcaps/test/properties.t

@@ -0,0 +1,23 @@
+Check that we get compile errors when trying to use a read-only or write-only property with the opposite operation:
+
+  $ cat >t.ml <<'EOF'
+  > open Xapi_fdcaps.Properties
+  > let _ = as_readable (make `wronly `reg) in ()
+  > EOF
+  $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml
+  File "t.ml", line 2, characters 40-42:
+  2 | let _ = as_readable (make `wronly `reg) in ()
+                                              ^^
+  Error: Syntax error
+  [2]
+
+  $ cat >t.ml <<'EOF'
+  > open Xapi_fdcaps.Properties
+  > let _ = as_writable (make `rdonly `reg) in ()
+  > EOF
+  $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml
+  File "t.ml", line 2, characters 40-42:
+  2 | let _ = as_writable (make `rdonly `reg) in ()
+                                              ^^
+  Error: Syntax error
+  [2]