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]. *)
let dir =
  let d = Filename.concat outer (Printf.sprintf "flan-t%d" owner) in
  (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  d

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. *)
let leftovers () =
  let mine =
    [ Filename.concat outer (Printf.sprintf "flan-dev-%d" owner);
      Filename.concat outer (Printf.sprintf "flan-%d" owner) ]
  in
  List.filter Sys.file_exists (dir :: mine)

(* 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)