CP-47001: [xapi-fdcaps]: add Safefd module

This module prevents double close errors.

Signed-off-by: Edwin Török <[email protected]>

lib/xapi-fdcaps/dune

@@ -3,5 +3,5 @@
 (library
 	(public_name xapi-fdcaps)
 	(name xapi_fdcaps)
-	(libraries unix)
+	(libraries fmt unix)
 )

lib/xapi-fdcaps/safefd.ml

@@ -0,0 +1,185 @@
+(*
+ * 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.
+ *)
+
+let string_of_file_kind =
+  let open Unix in
+  function
+  | S_REG ->
+      "regular file"
+  | S_BLK ->
+      "block device"
+  | S_CHR ->
+      "character device"
+  | S_DIR ->
+      "directory"
+  | S_LNK ->
+      "symlink"
+  | S_FIFO ->
+      "FIFO/pipe"
+  | S_SOCK ->
+      "socket"
+
+let pp_kind = Fmt.of_to_string string_of_file_kind
+
+module Identity = struct
+  type t = {
+      kind: Unix.file_kind
+    ; device: int
+    ; inode: int (* should be int64? *)
+  }
+
+  let of_fd fd =
+    let open Unix.LargeFile in
+    let stat = fstat fd in
+    {kind= stat.st_kind; device= stat.st_dev; inode= stat.st_ino}
+
+  let same a b = a.kind = b.kind && a.device = b.device && a.inode = b.inode
+
+  let pp =
+    Fmt.(
+      record
+        ~sep:Fmt.(any ", ")
+        [
+          field "kind" (fun t -> t.kind) pp_kind
+        ; field "device" (fun t -> t.device) int
+        ; field "inode" (fun t -> t.inode) int
+        ]
+    )
+end
+
+type t = {
+    fd: (Unix.file_descr, Printexc.raw_backtrace) result Atomic.t
+  ; opened_at: Printexc.raw_backtrace
+  ; original: Identity.t
+}
+
+let pp ppf t =
+  (* print only essential info that fits on a single line *)
+  Fmt.pf ppf "@[FD %a: %a@]"
+    (Fmt.result ~ok:Fmt.(any "open") ~error:Fmt.(any "closed"))
+    (Atomic.get t.fd) Identity.pp t.original
+
+let pp_closed ppf bt =
+  let exception Closed_at in
+  Fmt.exn_backtrace ppf (Closed_at, bt)
+
+let pp_opened_at ppf bt =
+  let exception Opened_at in
+  Fmt.exn_backtrace ppf (Opened_at, bt)
+
+let dump =
+  Fmt.(
+    Dump.(
+      record
+        [
+          field "fd"
+            (fun t -> Atomic.get t.fd)
+            Fmt.Dump.(result ~ok:(any "opened") ~error:pp_closed)
+        ; field "opened_at" (fun t -> t.opened_at) pp_opened_at
+        ; field "original" (fun t -> t.original) Identity.pp
+        ]
+    )
+  )
+
+let location () =
+  (* We could raise and immediately catch an exception but that will have a very short stacktrace,
+     [get_callstack] is better.
+  *)
+  Printexc.get_callstack 1000
+
+let nop =
+  {
+    fd= Atomic.make (Error (location ()))
+  ; opened_at= Printexc.get_callstack 0
+  ; original= Identity.of_fd Unix.stdin
+  }
+
+let check_exn ~caller t fd =
+  let actual = Identity.of_fd fd in
+  if not (Identity.same t.original actual) then (
+    let msg =
+      Format.asprintf "@[<h>File descriptor mismatch: %a != %a@]" Identity.pp
+        t.original Identity.pp actual
+    in
+    (* invalidate FD so nothing else uses it anymore, we know it points to elsewhere now *)
+    Atomic.set t.fd (Error (location ())) ;
+    (* raise backtrace with original open location *)
+    Printexc.raise_with_backtrace
+      Unix.(Unix_error (EBADF, caller, msg))
+      t.opened_at
+  )
+
+let close_common_exn t =
+  let closed = Error (location ()) in
+  (* ensure noone else can access it, before we close it *)
+  match Atomic.exchange t.fd closed with
+  | Error _ as e ->
+      (* put back the original backtrace *)
+      Atomic.set t.fd e ; e
+  | Ok fd ->
+      check_exn ~caller:"close_common_exn" t fd ;
+      Ok (Unix.close fd)
+
+let close_exn t =
+  match close_common_exn t with
+  | Error bt ->
+      let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in
+      (* raise with previous close's backtrace *)
+      Printexc.raise_with_backtrace ebadf bt
+  | Ok () ->
+      ()
+
+let idempotent_close_exn t =
+  let (_ : _ result) = close_common_exn t in
+  ()
+
+let leak_count = Atomic.make 0
+
+let leaked () = Atomic.get leak_count
+
+let finalise t =
+  match Atomic.get t.fd with
+  | Ok _ ->
+      Atomic.incr leak_count ;
+      if Sys.runtime_warnings_enabled () then
+        Format.eprintf "@.Warning: leaked file descriptor detected:@,%a@]@."
+          pp_opened_at t.opened_at
+  | Error _ ->
+      ()
+
+let of_file_descr fd =
+  let v =
+    {
+      fd= Atomic.make (Ok fd)
+    ; opened_at= location ()
+    ; original= Identity.of_fd fd
+    }
+  in
+  Gc.finalise finalise v ; v
+
+let unsafe_to_file_descr_exn t =
+  match Atomic.get t.fd with
+  | Ok fd ->
+      fd
+  | Error bt ->
+      let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in
+      Printexc.raise_with_backtrace ebadf bt
+
+let with_fd_exn t f =
+  let fd = unsafe_to_file_descr_exn t in
+  let r = f fd in
+  check_exn ~caller:"with_fd_exn" t fd ;
+  r
+
+let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore

lib/xapi-fdcaps/safefd.mli

@@ -0,0 +1,112 @@
+(*
+ * 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.
+ *)
+
+(** Safe wrapper around {!type:Unix.file_descr} that detects "use after close" errors
+
+  {!type:Unix.file_descr} is just an integer and cannot track whether {!val:Unix.close} has been called.
+  File descriptor numbers are reused by newly open file descriptors, so using a file descriptor that is already closed
+  doesn't always result in a visible error, but is nevertheless a programming error that should be detected.
+
+  E.g. the following sequence would write data to the wrong file ([fd2] instead of [fd1]),
+  and raise no errors at runtime:
+  {[    
+    let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in
+    Unix.close fd1;
+    let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in
+    Unix.write_substring fd1 "test" 0 4;
+    Unix.close fd2
+  ]}
+
+  This module introduces a lightweight wrapper around {!type:Unix.file_descr},
+   and detects attempts to use a file descriptor after it has been closed:
+  {[
+    open Xapi_fdcaps
+    
+    let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in
+    Safefd.close_exn fd1;
+    let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in
+    Safefd.with_fd_exn fd1 (fun fd -> Unix.write_substring fd "test" 0 4);
+  ]}
+
+  It raises {!val:Unix.EBADF}:
+  {[ Exception: Unix.Unix_error(Unix.EBADF, "unsafe_to_file_descr_exn", "") ]}
+
+  The callback of {!val:with_fd_exn} has access to the underlying {!type:Unix.file_descr},
+  and may accidentally call {!val:Unix.close}.
+
+  To detect that {!val:with_fd_exn} calls {!val:Unix.LargeFile.fstat} to check that the file descriptor
+  remained the "same" after the call.
+  File descriptors are considered to be the same if their kind, device and inode remain unchanged
+  (obviously other parts of the stat structure such as timestamps and size may change between calls).
+  This doesn't detect all bugs, but detects most common bugs
+  (hardlinked files will still show up as the same but the file position may have been different, which is not checked).
+
+  The extra system calls have an overhead so an unsafe version is available, but not documented (it should only be used internally by other modules in {!mod:Xapi_fdcaps}).
+
+  With the safe wrapper we also have a non-integer type that we can attach a finaliser too. 
+  This is used to detect and close leaked file descriptors safely (by checking that it is "the same" that we originally opened).
+*)
+
+(** a file descriptor that is safe against double close *)
+type t
+
+val of_file_descr : Unix.file_descr -> t
+(** [of_file_descr fd] wraps [fd].
+
+ *)
+
+val idempotent_close_exn : t -> unit
+(** [idempotent_close_exn t] closes [t], and doesn't raise an exception if [t] is already closed.
+  Other exceptions may still escape (e.g. if the underlying [close] has reported an [ENOSPC] or [EIO] error).
+*)
+
+val close_exn : t -> unit
+(** [close_exn t] closes t and raises an exception if [t] is already closed.
+
+  @raises Unix_error(Unix.EBADF,_,_) if [t] is already closed.
+*)
+
+val with_fd_exn : t -> (Unix.file_descr -> 'a) -> 'a
+(** [with_fd_exn t f] calls [f fd] with the underlying file descriptor.
+   [f] must not close [fd].
+
+  @raises Unix_error(Unix.EBADF,_,_) if the file descriptor is not the same after [f] terminates.
+*)
+
+val nop : t
+(** [nop] is a file descriptor that is always closed and no operations are valid on it. *)
+
+val pp : Format.formatter -> t -> unit
+(** [pp formatter t] pretty prints information about [t] on [formatter]. *)
+
+val dump : Format.formatter -> t -> unit
+(** [dump formatter t] prints all the debug information available about [t] on [formatter] *)
+
+(**/**)
+
+(* For small wrappers and high frequency calls like [read] and [write].
+   Should only be used by the wrappers in {!mod:Operations}, hence hidden from the documentation.
+*)
+
+val setup : unit -> unit
+(** [setup ()] sets up a [SIGPIPE] handler.
+   With the handler set up a broken pipe will result in a [Unix.EPIPE] exception instead of killing the program *)
+
+val leaked : unit -> int
+(** [leaked ()] is a count of leaked file descriptors detected.
+  Run [Gc.full_major ()] to get an accurate count before calling this *)
+
+(**/**)
+
+val unsafe_to_file_descr_exn : t -> Unix.file_descr

lib/xapi-fdcaps/test/dune

@@ -1,4 +1,5 @@
-(test
-	(name test_xapi_fdcaps)
+(tests
+	(package xapi-fdcaps)
+	(names test_safefd)
 	(libraries xapi_fdcaps alcotest)
 )