feat(cram): timeout for cram tests

doc/changes/12041.md

@@ -0,0 +1,3 @@
+- Added a `(timeout <float>)` field to the `(cram)` stanza to specify per-test
+  time limits. Tests exceeding the timeout are terminated with an error.
+  (#12041, @Alizter)

doc/reference/dune/cram.rst

@@ -80,3 +80,33 @@ Cram
       When set to ``false``, do not add the tests to the ``runtest`` alias.
       The default is to add every Cram test to ``runtest``, but this is not
       always desired.
+
+   .. describe:: (timeout <float>)
+
+      .. versionadded:: 3.20
+
+      Specify a time limit (in seconds) for each individual Cram test.
+
+      If a test takes longer than the specified timeout, Dune will terminate it
+      and report a timeout error. This can be useful to catch tests that hang
+      or take unexpectedly long.
+
+      The timeout is a floating-point number (e.g., `1.5` for 1.5 seconds).
+      Zero or negative values cause immediate failure when running the cram
+      test.
+
+      If multiple ``cram`` stanzas apply to the same test, the **lowest** of
+      all specified timeouts is used.
+
+      This field is typically used to guard against unresponsive or
+      non-terminating test cases.
+
+      Example:
+
+      .. code:: dune
+
+         (cram
+          (timeout 2.5))
+
+      This limits each selected test to at most 2.5 seconds of execution time.
+

src/dune_engine/process.ml

@@ -13,22 +13,44 @@ module Failure_mode = struct
     | Strict : ('a, 'a) t
     | Accept : int Predicate.t -> ('a, ('a, int) result) t
     | Return : ('a, 'a * int) t
+    | Timeout :
+        { timeout_seconds : float option
+        ; failure_mode : ('a, 'b) t
+        }
+        -> ('a, ('b, [ `Timed_out ]) result) t
 
-  let accepted_codes : type a b. (a, b) t -> int -> bool = function
+  let rec accepted_codes : type a b. (a, b) t -> int -> bool = function
     | Strict -> Int.equal 0
     | Accept exit_codes -> fun i -> Predicate.test exit_codes i
     | Return -> fun _ -> true
+    | Timeout { failure_mode; _ } -> accepted_codes failure_mode
+  ;;
+
+  let exit_code_of_result = function
+    | `Finished n -> n
+    | `Timeout -> Code_error.raise "should not return `Timeout" []
+  ;;
+
+  let timeout_seconds : type a b. (a, b) t -> float option = function
+    | Timeout { timeout_seconds; _ } -> timeout_seconds
+    | Strict | Accept _ | Return -> None
   ;;
 
-  let map_result : type a b. (a, b) t -> int -> f:(unit -> a) -> b =
-    fun mode t ~f ->
+  let rec map_result
+    : type a b. (a, b) t -> [ `Timeout | `Finished of int ] -> f:(unit -> a) -> b
+    =
+    fun mode result ~f ->
     match mode with
     | Strict -> f ()
     | Accept _ ->
-      (match t with
+      (match exit_code_of_result result with
        | 0 -> Ok (f ())
        | n -> Error n)
-    | Return -> f (), t
+    | Return -> f (), exit_code_of_result result
+    | Timeout { failure_mode; _ } ->
+      (match result with
+       | `Timeout -> Error `Timed_out
+       | `Finished _ -> Ok (map_result failure_mode result ~f))
   ;;
 end
 
@@ -857,9 +879,9 @@ let report_process_finished
 
 let set_temp_dir_when_running_actions = ref true
 
-let await { response_file; pid; _ } =
+let await ~timeout_seconds { response_file; pid; _ } =
   let+ process_info, termination_reason =
-    Scheduler.wait_for_build_process pid ~is_process_group_leader:true
+    Scheduler.wait_for_build_process ?timeout_seconds pid ~is_process_group_leader:true
   in
   Option.iter response_file ~f:Path.unlink_exn;
   process_info, termination_reason
@@ -1019,7 +1041,7 @@ let run_internal
         cmdline
       | _ -> Pp.nop
     in
-    let t =
+    let (t : t) =
       spawn
         ?dir
         ?env
@@ -1045,7 +1067,9 @@ let run_internal
       in
       Running_jobs.start id t.pid ~description ~started_at:t.started_at
     in
-    let* process_info, termination_reason = await t in
+    let* process_info, termination_reason =
+      await ~timeout_seconds:(Failure_mode.timeout_seconds fail_mode) t
+    in
     let+ () = Running_jobs.stop id in
     let result = Result.make t process_info fail_mode in
     let times =
@@ -1076,6 +1100,7 @@ let run_internal
          we're about to return. *)
       Result.close result;
       raise (Memo.Non_reproducible Scheduler.Run.Build_cancelled)
+    | Timeout -> `Timeout, times
     | Normal ->
       let output = Result.Out.get result.stdout ^ Result.Out.get result.stderr in
       Log.command ~command_line ~output ~exit_status:process_info.status;
@@ -1103,12 +1128,12 @@ let run_internal
             ~has_unexpected_stderr:result.stderr.unexpected_output
       in
       Result.close result;
-      res, times)
+      `Finished res, times)
 ;;
 
 let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode prog args
   =
-  let+ run =
+  let+ run, _ =
     run_internal
       ?dir
       ~display
@@ -1120,7 +1145,6 @@ let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode
       fail_mode
       prog
       args
-    >>| fst
   in
   Failure_mode.map_result fail_mode run ~f:ignore
 ;;
@@ -1166,7 +1190,7 @@ let run_capture_gen
       ~f
   =
   let fn = Temp.create File ~prefix:"dune" ~suffix:"output" in
-  let+ run =
+  let+ run, _ =
     run_internal
       ?dir
       ~display
@@ -1178,7 +1202,6 @@ let run_capture_gen
       fail_mode
       prog
       args
-    >>| fst
   in
   Failure_mode.map_result fail_mode run ~f:(fun () ->
     let x = f fn in
@@ -1258,4 +1281,5 @@ let run_inherit_std_in_out =
       prog
       args
     >>| fst
+    >>| Failure_mode.exit_code_of_result
 ;;

src/dune_engine/process.mli

@@ -5,13 +5,21 @@ module Action_output_on_success := Execution_parameters.Action_output_on_success
 module Action_output_limit := Execution_parameters.Action_output_limit
 
 module Failure_mode : sig
-  (** How to handle sub-process failures *)
+  (** How to handle sub-process failures. This type controls the way in which
+      the process we are running can fail. *)
   type ('a, 'b) t =
     | Strict : ('a, 'a) t (** Fail if the process exits with anything else than [0] *)
     | Accept : int Predicate.t -> ('a, ('a, int) result) t
     (** Accept the following non-zero exit codes, and return [Error code] if
         the process exits with one of these codes. *)
     | Return : ('a, 'a * int) t (** Accept any error code and return it. *)
+    | Timeout :
+        { timeout_seconds : float option
+        ; failure_mode : ('a, 'b) t
+        }
+        -> ('a, ('b, [ `Timed_out ]) result) t
+    (** In addition to the [failure_mode], finish early if [timeout_seconds]
+        was reached. *)
 end
 
 module Io : sig

src/dune_engine/scheduler.ml

@@ -877,6 +877,7 @@ let wait_for_process t pid =
 type termination_reason =
   | Normal
   | Cancel
+  | Timeout
 
 (* We use this version privately in this module whenever we can pass the
    scheduler explicitly *)
@@ -1325,18 +1326,24 @@ let inject_memo_invalidation invalidation =
 let wait_for_process_with_timeout t pid waiter ~timeout_seconds ~is_process_group_leader =
   Fiber.of_thunk (fun () ->
     let sleep = Alarm_clock.sleep (Lazy.force t.alarm_clock) ~seconds:timeout_seconds in
-    Fiber.fork_and_join_unit
-      (fun () ->
-         let+ res = Alarm_clock.await sleep in
-         if res = `Finished && Process_watcher.is_running t.process_watcher pid
-         then
-           if is_process_group_leader
-           then kill_process_group pid Sys.sigkill
-           else Unix.kill (Pid.to_int pid) Sys.sigkill)
-      (fun () ->
-         let+ res = waiter t pid in
-         Alarm_clock.cancel (Lazy.force t.alarm_clock) sleep;
-         res))
+    let+ clock_result =
+      Alarm_clock.await sleep
+      >>| function
+      | `Finished when Process_watcher.is_running t.process_watcher pid ->
+        if is_process_group_leader
+        then kill_process_group pid Sys.sigkill
+        else Unix.kill (Pid.to_int pid) Sys.sigkill;
+        `Timed_out
+      | _ -> `Finished
+    and+ res, termination_reason =
+      let+ res = waiter t pid in
+      Alarm_clock.cancel (Lazy.force t.alarm_clock) sleep;
+      res
+    in
+    ( res
+    , match clock_result with
+      | `Timed_out -> Timeout
+      | `Finished -> termination_reason ))
 ;;
 
 let wait_for_build_process ?timeout_seconds ?(is_process_group_leader = false) pid =
@@ -1353,16 +1360,7 @@ let wait_for_build_process ?timeout_seconds ?(is_process_group_leader = false) p
 ;;
 
 let wait_for_process ?timeout_seconds ?(is_process_group_leader = false) pid =
-  let* t = t () in
-  match timeout_seconds with
-  | None -> wait_for_process t pid
-  | Some timeout_seconds ->
-    wait_for_process_with_timeout
-      t
-      pid
-      wait_for_process
-      ~timeout_seconds
-      ~is_process_group_leader
+  wait_for_build_process ?timeout_seconds ~is_process_group_leader pid >>| fst
 ;;
 
 let sleep ~seconds =

src/dune_engine/scheduler.mli

@@ -104,6 +104,7 @@ val wait_for_process
 type termination_reason =
   | Normal
   | Cancel
+  | Timeout
 
 val wait_for_build_process
   :  ?timeout_seconds:float