From 6a1182df5dbf0d77f099843968e48f66bcad9a2a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 09:40:00 +0700 Subject: [PATCH] A test binary runs under a temporary directory of its own and leaves nothing in the one it was given --- TODO.org | 12 +++++ lib/build.ml | 19 ++++++- test/dune | 8 +-- test/own_tmp.ml | 108 ++++++++++++++++++++++++++++++++++++++++ test/test_acceptance.ml | 2 +- test/test_support.ml | 2 +- test/watchdog.ml | 1 + 7 files changed, 145 insertions(+), 7 deletions(-) create mode 100644 test/own_tmp.ml diff --git a/TODO.org b/TODO.org index b02cf6fc..c5a6fd76 100644 --- a/TODO.org +++ b/TODO.org @@ -1706,6 +1706,18 @@ as it is left to; in CI that is a job the runner kills with nothing named. The alarm is generous on purpose, because an alarm that fires on a slow machine is a flake and a flake is how a watchdog gets deleted. +** DONE A test binary leaves nothing in the temporary directory it was given +CLOSED: [2026-09-25] +Every test binary makes =flan-t= under its =TMPDIR=, exports it as +=TMPDIR= to everything it starts, and removes it on exit, on the watchdog, and +on SIGINT or SIGTERM (=test/own_tmp.ml=). A binary exits nonzero if that +directory survives or if a =flan-= or =flan-dev-= for its own pid +appears beside it. =dune test= was already clean, since dune gives every action +a private =TMPDIR=; the directories in /tmp came from binaries run directly or +through =dune exec=. A build's empty =flan-= goes at process exit. Rules out +a sweep that deletes directories by pid liveness, and any change to a killed or +crashed session keeping its directory. + ** DONE A forked acceptance failure reaches the exit status The fork pool is drained before anything reads the failure count, and a nonzero count is an exit status. A red row used to be able to print and pass. diff --git a/lib/build.ml b/lib/build.ml index c86fc27b..440b786e 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -43,13 +43,30 @@ let read_file_opt path = try Some (read_file path) with Sys_error _ -> None (* One temporary directory per build, so the .ll is findable by name when - something is wrong with it. *) + something is wrong with it. + + A build that succeeds removes what it wrote there, and the directory itself + goes when the process exits: [rmdir], which only removes an empty directory, + so a failed build's files and the directory holding them stay. Not before + exit, because every build in the process shares the directory and one that + removed it would pull it out from under the next write of another. Only by + the process that made it: a forked child exiting through [exit] runs the + parent's handlers too. *) +let workdir_exit = ref None + let workdir () = let d = Filename.concat (Filename.get_temp_dir_name ()) (Printf.sprintf "flan-%d" (Unix.getpid ())) in (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); + if !workdir_exit <> Some d then begin + workdir_exit := Some d; + let pid = Unix.getpid () in + at_exit (fun () -> + if Unix.getpid () = pid then + try Unix.rmdir d with Unix.Unix_error _ -> ()) + end; d (* [mkdir -p]: each component in turn, [EEXIST] swallowed at each, because the diff --git a/test/dune b/test/dune index 58110461..a252d01d 100644 --- a/test/dune +++ b/test/dune @@ -46,7 +46,7 @@ ; wanted them had each been carrying their own copy of. (modules test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider test_dyn watchdog - test_support) + test_support own_tmp) (libraries flan unix) (deps (alias corpus) @@ -87,7 +87,7 @@ ; skips with the reason, so it is green on a machine that has neither. (test (name test_web) - (modules test_web test_support) + (modules test_web test_support own_tmp) (libraries flan unix) (deps (alias corpus) @@ -105,7 +105,7 @@ ; is the whole point here. (executable (name test_sanitize) - (modules test_sanitize watchdog test_support) + (modules test_sanitize watchdog test_support own_tmp) (libraries flan unix)) (rule @@ -141,7 +141,7 @@ ; asked for exactly this. (executable (name test_valgrind) - (modules test_valgrind watchdog test_support) + (modules test_valgrind watchdog test_support own_tmp) (libraries flan unix str)) (rule diff --git a/test/own_tmp.ml b/test/own_tmp.ml new file mode 100644 index 00000000..4dda3a77 --- /dev/null +++ b/test/own_tmp.ml @@ -0,0 +1,108 @@ +(* 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-], and a build keeps its files in + [$TMPDIR/flan-]. 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-/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; + 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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 64a1bba7..9ad25cc4 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -38,7 +38,7 @@ let failures = Test_support.failures handler's [exit] call would do to it. *) let () = at_exit (fun () -> - if !failures > 0 then begin flush_all (); Unix._exit 1 end) + if !failures > 0 then begin flush_all (); Own_tmp.release (); Unix._exit 1 end) let scratch = Test_support.scratch diff --git a/test/test_support.ml b/test/test_support.ml index 1433b626..33622278 100644 --- a/test/test_support.ml +++ b/test/test_support.ml @@ -82,7 +82,7 @@ let contains hay needle = (* ── Scratch files ────────────────────────────────────────────────── *) -let scratch = Filename.get_temp_dir_name () +let scratch = Own_tmp.dir (* [tmp prefix name] is a path in the scratch directory. The prefix is the caller's, not a default, and that is the point: these binaries run at the diff --git a/test/watchdog.ml b/test/watchdog.ml index f3dd8119..75beecbf 100644 --- a/test/watchdog.ml +++ b/test/watchdog.ml @@ -62,6 +62,7 @@ let dying _ = coordinating with what is in it, and does not depend on how many handlers get added there later. *) flush_all (); + Own_tmp.release (); Unix._exit 2 (* Re-arm the backstop for whatever is left of its budget. One second is the