feature: trace events for cram commands

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

bin/common.ml

@@ -1316,6 +1316,7 @@ let init_with_root ~(root : Workspace_root.t) (builder : Builder.t) =
             ; Log
             ; File_watcher
             ; Diagnostics
+            ; Cram
             ]
         | Some s ->
           String.split ~on:',' s

doc/changes/added/13092.md

@@ -0,0 +1,2 @@
+- Add timing information for every command executed by cram (#13092,
+  @rgrinberg)

src/dune_rules/cram/cram_exec.ml

@@ -174,12 +174,14 @@ let dyn_of_metadata_result =
 type full_block_result =
   { block : block_result
   ; metadata : metadata_result
+  ; duration : Time.Span.t option
   }
 
 type sh_script =
   { script : Path.t
   ; cram_to_output : block_result Cram_lexer.block list
   ; metadata_file : Path.t option
+  ; time_file : Path.t option
   }
 
 let read_exit_codes_and_prefix_maps file =
@@ -210,22 +212,49 @@ let read_exit_codes_and_prefix_maps file =
   loop [] (String.split ~on:'\000' s)
 ;;
 
+let read_times file =
+  let open Option.O in
+  let* file = file in
+  let+ contents = Option.try_with (fun () -> Io.read_file file ~binary:true) in
+  String.split_lines contents
+  |> List.filter_map ~f:(fun s ->
+    match String.trim s with
+    | "" -> None
+    | s -> Float.of_string s >>| Time.Span.of_secs)
+;;
+
 let read_and_attach_exit_codes (sh_script : sh_script)
   : full_block_result Cram_lexer.block list
   =
   let metadata_entries = read_exit_codes_and_prefix_maps sh_script.metadata_file in
-  let rec loop acc entries blocks =
+  let times = read_times sh_script.time_file in
+  let next_time = function
+    | None -> None, None
+    | Some [] -> None, Some []
+    | Some (time :: times) -> Some time, Some times
+  in
+  let rec loop acc entries blocks times =
     match blocks, entries with
     | [], [] -> List.rev acc
-    | (Cram_lexer.Comment _ as comment) :: blocks, _ ->
-      loop (comment :: acc) entries blocks
+    | (Cram_lexer.Comment _ as comment) :: blocks, __ ->
+      loop (comment :: acc) entries blocks times
     | Command block :: blocks, metadata_entry :: entries ->
-      loop (Command { block; metadata = Present metadata_entry } :: acc) entries blocks
+      let duration, times = next_time times in
+      loop
+        (Command { block; metadata = Present metadata_entry; duration } :: acc)
+        entries
+        blocks
+        times
     | Cram_lexer.Command block :: blocks, [] ->
-      loop (Command { block; metadata = Missing_unreachable } :: acc) entries blocks
+      let duration, times = next_time times in
+      loop
+        (Command { block; metadata = Missing_unreachable; duration } :: acc)
+        entries
+        blocks
+        times
     | [], _ :: _ -> Code_error.raise "more blocks than metadata" []
   in
-  loop [] metadata_entries sh_script.cram_to_output
+  loop [] metadata_entries sh_script.cram_to_output times
 ;;
 
 let line_number =
@@ -279,7 +308,7 @@ let sanitize ~parent_script cram_to_output : command_out Cram_lexer.block list =
   List.map cram_to_output ~f:(fun (t : full_block_result Cram_lexer.block) ->
     match t with
     | Cram_lexer.Comment t -> Cram_lexer.Comment t
-    | Command { block; metadata } ->
+    | Command { block; metadata; duration = _ } ->
       let output =
         match metadata with
         | Missing_unreachable -> "***** UNREACHABLE *****"
@@ -338,7 +367,9 @@ let cram_commmands commands =
   Buffer.contents buf
 ;;
 
-let create_sh_script cram_stanzas ~temp_dir ~setup_scripts : sh_script Fiber.t =
+let create_sh_script cram_stanzas ~temp_dir ~setup_scripts (shell : Cram_stanza.Shell.t)
+  : sh_script Fiber.t
+  =
   let script = Path.relative temp_dir "main.sh" in
   let oc = Io.open_out ~binary:true script in
   Fiber.finalize ~finally:(fun () -> Fiber.return @@ close_out oc)
@@ -350,6 +381,18 @@ let create_sh_script cram_stanzas ~temp_dir ~setup_scripts : sh_script Fiber.t =
     quote_for_sh path
   in
   let metadata_file = file "cram.metadata" in
+  let user_shell_time_file =
+    match shell with
+    | Sh -> None
+    | Bash -> Some (file "time")
+  in
+  let* user_shell_time_file_sh_path =
+    match user_shell_time_file with
+    | None -> Fiber.return None
+    | Some f ->
+      let+ file = sh_path f in
+      Some file
+  in
   let* metadata_file_sh_path = sh_path metadata_file in
   let i = ref 0 in
   let loop block =
@@ -370,11 +413,18 @@ let create_sh_script cram_stanzas ~temp_dir ~setup_scripts : sh_script Fiber.t =
       (* Where we store the output of shell code written by the user *)
       let user_shell_code_output_file = file ~ext:".output" in
       let+ user_shell_code_output_file_sh_path = sh_path user_shell_code_output_file in
+      let untimed_command =
+        sprintf
+          ". %s > %s 2>&1"
+          user_shell_code_file_sh_path
+          user_shell_code_output_file_sh_path
+      in
       fprln
         oc
-        ". %s > %s 2>&1"
-        user_shell_code_file_sh_path
-        user_shell_code_output_file_sh_path;
+        "%s"
+        (match user_shell_time_file_sh_path with
+         | None -> untimed_command
+         | Some time_file -> sprintf "{ time %s; } 2>> %s" untimed_command time_file);
       fprln
         oc
         {|printf "%%d\0%%s\0" $? "$%s" >> %s|}
@@ -396,10 +446,14 @@ let create_sh_script cram_stanzas ~temp_dir ~setup_scripts : sh_script Fiber.t =
       | External _ -> ()
       | In_build_dir _ -> fprln oc "rm -f %s" script_sh_path)
   in
+  (* Needed for us to capture timing information. Users shouldn't really care,
+     but if they do, they can always set this again within their command (and
+     break timings) *)
+  fprln oc "TIMEFORMAT=\"%%3R\"";
   let+ cram_to_output = Fiber.sequential_map ~f:loop cram_stanzas in
   let command_count = !i in
   let metadata_file = Option.some_if (command_count > 0) metadata_file in
-  { script; cram_to_output; metadata_file }
+  { script; cram_to_output; metadata_file; time_file = user_shell_time_file }
 ;;
 
 let _display_with_bars s = List.iter (String.split_lines s) ~f:(Printf.eprintf "| %s\n")
@@ -447,7 +501,7 @@ let run_cram_test
       (shell : Cram_stanza.Shell.t)
   =
   let open Fiber.O in
-  let* sh_script = create_sh_script cram_stanzas ~temp_dir ~setup_scripts in
+  let* sh_script = create_sh_script cram_stanzas ~temp_dir ~setup_scripts shell in
   let env = make_run_env env ~temp_dir ~cwd in
   let open Fiber.O in
   let sh =
@@ -481,7 +535,19 @@ let run_cram_test
     sh
     [ Path.to_string sh_script.script ]
   >>| function
-  | Ok () -> read_and_attach_exit_codes sh_script |> sanitize ~parent_script:script
+  | Ok () ->
+    let detailed_output = read_and_attach_exit_codes sh_script in
+    Dune_trace.emit Cram (fun () ->
+      (* CR-someday rgrinberg: a little lame that we don't have a good way
+         to relate these to the underlying process event. *)
+      List.filter_map detailed_output ~f:(function
+        | Comment _ -> None
+        | Command { duration; block = { command; _ }; _ } ->
+          (match duration with
+           | None -> None
+           | Some duration -> Some { Dune_trace.Event.Cram.command; dur = duration }))
+      |> Dune_trace.Event.Cram.test);
+    sanitize ~parent_script:script detailed_output
   | Error `Timed_out ->
     let timeout_loc, timeout = Option.value_exn timeout in
     let timeout_set_message =

src/dune_trace/category.ml

@@ -17,6 +17,7 @@ type t =
   | File_watcher
   | Diagnostics
   | Log
+  | Cram
 
 let all =
   [ Rpc
@@ -35,6 +36,7 @@ let all =
   ; File_watcher
   ; Diagnostics
   ; Log
+  ; Cram
   ]
 ;;
 
@@ -55,6 +57,7 @@ let to_string = function
   | File_watcher -> "file_watcher"
   | Diagnostics -> "diagnostics"
   | Log -> "log"
+  | Cram -> "cram"
 ;;
 
 let of_string =
@@ -87,5 +90,6 @@ module Set = Bit_set.Make (struct
       | File_watcher -> 13
       | Diagnostics -> 14
       | Log -> 15
+      | Cram -> 16
     ;;
   end)

src/dune_trace/category.mli

@@ -15,6 +15,7 @@ type t =
   | File_watcher
   | Diagnostics
   | Log
+  | Cram
 
 val to_string : t -> string
 val of_string : string -> t option

src/dune_trace/dune_trace.mli

@@ -18,6 +18,7 @@ module Category : sig
     | File_watcher
     | Diagnostics
     | Log
+    | Cram
 
   val of_string : string -> t option
 end
@@ -126,6 +127,15 @@ module Event : sig
     val accept : success:bool -> error:string option -> t
     val close : id:int -> t
   end
+
+  module Cram : sig
+    type command =
+      { command : string list
+      ; dur : Time.Span.t
+      }
+
+    val test : command list -> t
+  end
 end
 
 module Out : sig

src/dune_trace/event.ml

@@ -432,3 +432,26 @@ let log { Log.Message.level; message; args } =
   in
   Event.instant ~args ~name now Log
 ;;
+
+module Cram = struct
+  type command =
+    { command : string list
+    ; dur : Time.Span.t
+    }
+
+  let test commands =
+    let now = Time.now () in
+    let args =
+      [ ( "commands"
+        , List.map commands ~f:(fun { command; dur } ->
+            Arg.record
+              [ "command", Arg.list (List.map command ~f:Arg.string)
+              ; "dur", Event.make_dur dur
+              ]
+            |> Arg.list)
+          |> Arg.list )
+      ]
+    in
+    Event.instant ~args ~name:"cram" now Cram
+  ;;
+end

test/blackbox-tests/test-cases/cram/bash-shell.t

@@ -5,7 +5,7 @@ Demonstrate the shell field in the cram stanza
   > EOF
 
   $ printShell() {
-  > dune trace cat | jq '.[] | select(.cat == "process" and (.args.categories | index("cram"))) | .args | .prog | split("/") | last'
+  > dune trace cat | jq 'select(.cat == "process" and (.args.categories | index("cram"))) | .args | .prog | split("/") | last'
   > }
 
   $ cat >foo.t <<'EOF'
@@ -30,3 +30,15 @@ Demonstrate the shell field in the cram stanza
   [1]
   $ printShell
   "bash"
+
+  $ dune trace cat | jq 'select(.cat == "cram") | .args | (.. | .dur? // empty) |= "redacted"'
+  {
+    "commands": [
+      {
+        "command": [
+          "echo foo"
+        ],
+        "dur": "redacted"
+      }
+    ]
+  }

test/blackbox-tests/test-cases/cram/trace-commands.t

@@ -0,0 +1,57 @@
+Demonstrate command level trace events
+
+  $ cat > dune-project <<EOF
+  > (lang dune 3.22)
+  > EOF
+
+  $ cat > dune <<EOF
+  > (cram
+  >  (shell bash))
+  > EOF
+
+  $ cat >foo.t <<'EOF'
+  >   $ echo a
+  >   > echo b
+  > Break
+  >   $ echo c
+  > EOF
+
+  $ dune runtest foo.t
+  File "foo.t", line 1, characters 0-0:
+  Error: Files _build/default/foo.t and _build/default/foo.t.corrected differ.
+  [1]
+
+  $ dune trace cat | jq 'select(.cat == "cram") | .args | (.. | .dur? // empty) |= "redacted"'
+  {
+    "commands": [
+      {
+        "command": [
+          "echo a",
+          "echo b"
+        ],
+        "dur": "redacted"
+      },
+      {
+        "command": [
+          "echo c"
+        ],
+        "dur": "redacted"
+      }
+    ]
+  }
+
+We have to override TIMEFORMAT to get this timing information:
+
+  $ cat >timeformat.t <<'EOF'
+  >   $ echo $TIMEFORMAT
+  > EOF
+
+  $ dune runtest timeformat.t
+  File "timeformat.t", line 1, characters 0-0:
+  Error: Files _build/default/timeformat.t and
+  _build/default/timeformat.t.corrected differ.
+  [1]
+  $ dune promotion show timeformat.t
+    $ echo $TIMEFORMAT
+    %3R
+