flan/test/test_support.ml

(* The plumbing every test binary in this directory needs, in one place.

   Nothing here tests anything. It is the scaffolding the cases stand on: a
   failure counter and the three lines that report it, a poll, a socket
   connect that survives the bind/listen race, the wait for a [flan dev]
   daemon to come up, a substring search, and the Load → Check → Reach.link
   front half of a compile.

   It exists because each of those had been written out again in every file
   that wanted it — [listening] three times byte for byte apart from one
   comment, the substring search ten times, a report tail in every suite — and
   two of those copies carried a comment saying they were kept separate
   because "these three files have no module between them". That was not true
   when it was written: watchdog.ml was already named in the same
   [(modules ...)] stanzas, which is exactly the module between them. This
   file is the second such module, named in all four of test/dune's stanzas
   the way watchdog is in three of them.

   No [let () = ...] at the top level here on purpose. A module linked into
   ten binaries must not do anything on the way in; the watchdog is armed by
   each test's own first line, where the seconds are that test's decision. *)

open Flan

(* ── Failures, and the report of them ─────────────────────────────── *)

(* One counter per process, and every [fail] goes through it. Each binary
   binds its own [failures] to this ref rather than making one of its own, so
   [report] below sees what the file's own [incr failures] did. *)
let failures = ref 0

let fail fmt =
  Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt

(* What a build that raised says, for a [fail] line. [Failure] carries its
   text bare; anything else, a [Loc.Error] most of all, goes through the
   printer [Loc] registers, which is the diagnostic itself. A sweep that caught
   only [Failure] died on the first source error it met — "no package at ...",
   from a package the build tree was missing — with no FAIL line and every row
   after it unrun. *)
let raised = function Failure m -> m | e -> Printexc.to_string e

(* The tail every suite ends on: a single line when nothing failed, and a
   count plus a nonzero exit when something did. The label names the suite,
   because these binaries run under dune's parallelism and their output is
   interleaved — "all tests passed" on its own says nothing about which.
   [?label] is optional for the one caller that has no label to give: the
   last of test_flan.ml's three tails covers the whole file and has always
   printed the bare sentence, and this keeps that byte for byte.

   Not every tail in this directory is this one, and the others are left
   where they are: test_repl.ml quotes the daemon's exit status underneath
   the count, test_web.ml says "web: ok", and the two sweep binaries print a
   count without exiting on the spot. Those differ because they report
   different things, not because they drifted. *)
let report ?label () =
  if !failures = 0 then
    print_endline
      (match label with
       | Some l -> l ^ ": all tests passed"
       | None -> "all tests passed")
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end

(* ── Strings ──────────────────────────────────────────────────────── *)

(* Substring search, hand-written because Str is a dependency the rest of
   this directory does not take (test_valgrind.ml is the one exception, and
   it takes it for a regexp over memcheck's summary line).

   An empty needle is contained in anything, which is the answer the majority
   of the copies this replaces gave and the one that agrees with every other
   [contains] in the world. Three inline copies in test_dev.ml answered
   [false] instead; every needle passed to any of them was a non-empty string
   literal, so no call site could tell the difference. *)
let contains hay needle =
  let n = String.length needle and h = String.length hay in
  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
  go 0

(* ── Scratch files ────────────────────────────────────────────────── *)

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
   same time under dune, so "flan-agent-dev.sock" and "flan-repl-dev.sock"
   being different files is what keeps two suites from unlinking each other's
   sockets. *)
let tmp prefix name =
  (* A socket goes without the prefix: [scratch] is this binary's alone, and a
     unix socket path is short (see [Wire.max_socket_path]), which an emacs
     client connecting by the plain path cannot get around. *)
  if Filename.check_suffix name ".sock" then Filename.concat scratch name
  else Filename.concat scratch (prefix ^ name)

(* ── Toolchain probes ─────────────────────────────────────────────── *)

(* Whether a program is on PATH. Missing tools are a skip with the reason in
   this directory, never a red test — the compiler does not depend on emacs,
   emscripten or valgrind being installed. *)
let have prog =
  Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" prog) = 0

(* ── Waiting ──────────────────────────────────────────────────────── *)

(* Poll for a condition rather than sleeping a fixed time: a program has to
   bind its socket before there is anything to connect to, and how long that
   takes is not ours to predict. Five milliseconds a turn, [ms] milliseconds
   in total, [false] if the budget ran out.

   Five seconds by default, which is what test_dev.ml's copy had and what its
   several dozen bare call sites were written against. The callers that want
   another budget pass one. *)
let rec await ?(ms = 5000) f =
  if f () then true
  else if ms <= 0 then false
  else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end

(* The socket file appears at [bind], which is a moment before [listen], so a
   connect can lose that race and get ECONNREFUSED. Retry rather than sleep.

   ECONNREFUSED and not any [Unix_error], which is the narrower of the two
   spellings this had grown. The wide one retried ENOENT and EACCES to the
   full timeout as well, so a path that was never going to exist cost seconds
   before raising something a reader still had to interpret; narrowed, those
   two come straight back out of [Unix.connect] with their own name on them.
   Every caller here connects to a socket [listening] has already seen on
   disk, so the race this does catch is the only one left. *)
let rec connect ?(ms = 5000) path =
  let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  match Wire.connect_socket s path with
  | () -> s
  | exception Unix.Unix_error (Unix.ECONNREFUSED, _, _) when ms > 0 ->
    Unix.close s;
    ignore (Unix.select [] [] [] 0.005);
    connect ~ms:(ms - 5) path

(* Waiting for a daemon to listen is waiting for two different things with one
   timer: [flan dev] compiles the whole program first, and only then binds. The
   old message, "the daemon never listened", named the second and was almost
   always the first — which is a wrong diagnosis, and a wrong diagnosis costs
   more than no message at all.

   So this says which. It cannot separate the two waits without a signal from
   [flan dev] that the build is done (see TODO.org, "test_dev daemons fail to
   bind under load"), but it can separate the two *failures*, and that is what
   actually gets read: a daemon still running when
   the timer expires was building, and a daemon that is gone bound nothing
   because it died. The second no longer costs the whole timeout either —
   the poll watches the process as well as the socket, so a crash fails in
   milliseconds instead of in half a minute, which is the part that makes a
   suite worth trusting.

   Thirty seconds, down from a minute, because the object cache is durable now
   (Build.cachedir) and the build this waits on is warm: 0.48s idle against
   2.0s cold, and the worst ever measured under dune's own parallelism was
   6.8s — cold. Each caller's watchdog is still what bounds its run.

   [!listen_why] carries the reason to the caller so each site can keep its own
   name for its daemon. One ref is enough even though three binaries now share
   this code: they are three processes, each single-threaded, and the next
   thing after a failed wait is always the report of it. *)
let listen_why = ref ""

(* A signal as [WSIGNALED] carries it, by name. OCaml numbers the signals it
   knows negatively and in its own order — [Sys.sigterm] is -11 and
   [Sys.sigsegv] is -10 — so printing the number reads as the wrong signal to
   anyone who knows the POSIX table: a daemon terminated by SIGTERM was once
   recorded here as "a transient signal 11", a segfault that never happened. *)
let signal_name n =
  let known =
    [ Sys.sigabrt, "SIGABRT"; Sys.sigalrm, "SIGALRM"; Sys.sigfpe, "SIGFPE";
      Sys.sighup, "SIGHUP"; Sys.sigill, "SIGILL"; Sys.sigint, "SIGINT";
      Sys.sigkill, "SIGKILL"; Sys.sigpipe, "SIGPIPE"; Sys.sigquit, "SIGQUIT";
      Sys.sigsegv, "SIGSEGV"; Sys.sigterm, "SIGTERM"; Sys.sigusr1, "SIGUSR1";
      Sys.sigusr2, "SIGUSR2"; Sys.sigchld, "SIGCHLD"; Sys.sigbus, "SIGBUS";
      Sys.sigtrap, "SIGTRAP"; Sys.sigxcpu, "SIGXCPU" ]
  in
  match List.assoc_opt n known with
  | Some s -> s
  | None -> Printf.sprintf "signal %d" n

let listening ?(ms = 30000) ~pid path =
  let died = ref None in
  ignore
    (await ~ms (fun () ->
         Sys.file_exists path
         ||
         (* Reaped only once it is already gone, and only on the path that ends
            in a failure, so a teardown's own [waitpid] is unaffected. *)
         match Unix.waitpid [ Unix.WNOHANG ] pid with
         | 0, _ -> false
         | _, st -> died := Some st; true
         | exception Unix.Unix_error _ -> false));
  if Sys.file_exists path then true
  else begin
    listen_why :=
      (match !died with
       | Some (Unix.WEXITED n) ->
         Printf.sprintf "exited with status %d before binding %s" n path
       | Some (Unix.WSIGNALED n) ->
         Printf.sprintf "was killed by %s before binding %s" (signal_name n) path
       (* Unreachable without WUNTRACED, and here only for exhaustiveness. *)
       | Some (Unix.WSTOPPED n) ->
         Printf.sprintf "stopped on %s without binding %s" (signal_name n) path
       | None ->
         Printf.sprintf
           "was still running after %ds without binding %s, so it was the \
            build that did not finish, not the socket"
           (ms / 1000) path);
    false
  end

(* ── The front half of a compile ──────────────────────────────────── *)

(* Read, load and check a program, through [Front], which is the path
   [flan build] takes too. Without [~all], so a refusal raises the first error
   rather than the list. Through [Load], so a program with an (import ...) is
   buildable here — it brings back the package's declarations as well as the
   file's own. *)
let checked path = snd (Front.checked path)

(* And the link, which is where the binaries below actually differ from
   one another: [Reach.link] decides the link from the checked program — a
   package nothing reachable calls into hands over no C and no linker
   argument, and its functions are not emitted — and returns the program
   together with the C sources and linker flags the build needs.

   This stops at [Build.executable] deliberately. Every caller passes a
   different [Build.opts] (a sanitized build, a -O0 one, an x86 one, a web
   one) and several want the exception rather than the executable, so the
   options record is the one part that is genuinely theirs. *)
let linked ?dev path =
  let f = Front.linked ?dev path in
  (f.Front.program, f.Front.csrcs, f.Front.lflags)