A test binary runs under a temporary directory of its own and leaves nothing in the one it was given
This commit is contained in:
parent
11dc230974
commit
6a1182df5d
12
TODO.org
12
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<pid>= 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-<pid>= or =flan-dev-<pid>= 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-<pid>= 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.
|
||||
|
||||
19
lib/build.ml
19
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
|
||||
|
||||
@ -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
|
||||
|
||||
108
test/own_tmp.ml
Normal file
108
test/own_tmp.ml
Normal file
@ -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-<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;
|
||||
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)
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user