flan/test/own_tmp.ml

(* Every test binary runs under a temporary directory of its own, and takes it
   away when it exits.

   A [flan dev] session keeps its program, its socket and every module it was
   sent in [$TMPDIR/flan-dev-<pid>], and a build keeps its files in
   [$TMPDIR/flan-<pid>]. A session told to [close] removes both; one that is
   killed or crashes leaves them, because what a crashed session was running is
   what there is to look at afterwards. The suite kills and crashes daemons on
   purpose, so every run of test_dev leaves a score of those behind.

   Under [dune test] that never reached /tmp: dune hands every action a
   [TMPDIR] of its own and removes it when the build ends. A binary run any
   other way — [dune exec], or [_build/default/test/test_dev.exe] in a loop
   while chasing a flake — has no such directory, and each run put its
   sessions' directories straight into /tmp, which is a tmpfs.

   So the directory those land in is this binary's. It is made when this module
   is initialised, which is before any test module's own top level runs,
   because [Test_support] and [Watchdog] both refer to it and every binary here
   refers to one of them (test_cider only to [Watchdog], through [dying]'s call
   to [release] — take that call out and test_cider loses its directory). It is
   exported as [TMPDIR] as well as set as OCaml's temporary directory, so every
   [flan dev], emacs and program this binary starts puts its directories under
   it too; every child here is started with an environment derived from
   [Unix.environment ()], which carries it.

   It is removed however the binary ends: a normal exit, a failing one, an
   uncaught exception, the watchdog, or SIGINT or SIGTERM. SIGKILL is the one
   end nothing can follow.

   Nothing here decides whether a session is over. The tree goes because the
   binary that owns it is exiting, and anything in it was made by this binary
   or by something it started. *)

let outer = Filename.get_temp_dir_name ()
let owner = Unix.getpid ()

(* Short, because a Unix socket path has 108 bytes and the sockets the tests
   bind are under here: [flan-dev-<pid>/agent.sock], and names such as
   [flan-devtest-halfwrite--llvm.sock].

   Made fresh, never adopted: [mkdir] fails on any existing entry, a symlink
   included, and a name that is taken is passed over for another. So the
   directory this binary removes at exit is one it provably created, and
   nothing someone else put at that name is followed or deleted. *)
let dir =
  Random.self_init ();
  let rec make tries =
    let d =
      Filename.concat outer
        (Printf.sprintf "flan-t%d-%04x" owner (Random.bits () land 0xffff))
    in
    match Unix.mkdir d 0o700 with
    | () -> d
    | exception Unix.Unix_error (Unix.EEXIST, _, _) when tries > 0 ->
      make (tries - 1)
  in
  make 100

let () =
  Unix.putenv "TMPDIR" dir;
  Filename.set_temp_dir_name dir

let rec remove path =
  match (Unix.lstat path).Unix.st_kind with
  | Unix.S_DIR ->
    Array.iter
      (fun n -> remove (Filename.concat path n))
      (try Sys.readdir path with Sys_error _ -> [||]);
    (try Unix.rmdir path with Unix.Unix_error _ -> ())
  | _ -> (try Unix.unlink path with Unix.Unix_error _ -> ())
  | exception Unix.Unix_error _ -> ()

(* What this binary left where it should have left nothing: its own directory,
   if removing it failed, and a session or build directory named for this
   process in the directory it was given. The second is an in-process session
   or build that did not go through [dir] — something that read the temporary
   directory before this module set it. A name already there when this binary
   started belongs to an earlier process that had the same pid, and is not
   counted. *)
let named_for_me =
  [ Filename.concat outer (Printf.sprintf "flan-dev-%d" owner);
    Filename.concat outer (Printf.sprintf "flan-%d" owner) ]

let already = List.filter Sys.file_exists named_for_me

let leftovers () =
  List.filter
    (fun d -> Sys.file_exists d && not (List.mem d already))
    (dir :: named_for_me)

(* Only the process that made the directory removes it. The binaries fork
   (test_acceptance's compile pool, the daemons before they exec), and a
   forked child that ran this on its way out would take the directory from
   under the parent that is still using it.

   A leftover ends the process with status 1 on the spot. OCaml runs [at_exit]
   before it prints an uncaught exception, so a binary that both raised and
   leaked shows the leak and not the exception; one that only raised is
   unaffected. *)
let released = ref false

let release () =
  if Unix.getpid () = owner && not !released then begin
    released := true;
    remove dir;
    (* Twice, because a child still exiting — a daemon's clang, a program
       the test just signalled — can write between one pass's [readdir] and
       its [rmdir], and a check that fails on that is a flake. *)
    if Sys.file_exists dir then remove dir;
    match leftovers () with
    | [] -> ()
    | left ->
      Printf.printf
        "FAIL  %s left temporary directories behind:\n%s\n"
        (Filename.basename Sys.executable_name)
        (String.concat "\n" (List.map (fun d -> "        " ^ d) left));
      flush_all ();
      Unix._exit 1
  end

let () =
  at_exit release;
  let stop n =
    Sys.Signal_handle
      (fun _ ->
        (try release () with _ -> ());
        flush_all ();
        Unix._exit (128 + n))
  in
  Sys.set_signal Sys.sigint (stop 2);
  Sys.set_signal Sys.sigterm (stop 15)