Add test runners (#3)

dune-project

@@ -22,6 +22,7 @@
   (fmt (and (>= 0.9) (< 0.10)))
   (ppxlib (and (>= 0.30) (< 0.31)))
   (ocaml-compiler-libs (and (>= v0.12) (< v0.13)))
+  (cmdliner (and (>= 1.2) (< 1.3)))
  )
 )
 

index.mld

@@ -8,4 +8,4 @@ This framework consists of a number of libraries and executables for testing unt
 
 The following components are included in the package:
 
-{!modules: Ast_check Stdlib_variants Test_lib Common}
+{!modules: Ast_check Stdlib_variants Test_lib Test_runner Common}

less-power.opam

@@ -21,6 +21,7 @@ depends: [
   "fmt" {>= "0.9" & < "0.10"}
   "ppxlib" {>= "0.30" & < "0.31"}
   "ocaml-compiler-libs" {>= "v0.12" & < "v0.13"}
+  "cmdliner" {>= "1.2" & < "1.3"}
   "odoc" {with-doc}
 ]
 build: [

src/common/ctx_util.ml

@@ -18,7 +18,7 @@ let with_context (cm : _ t) f =
   in
   match cm k with
   | Ok x -> x
-  | Error e -> raise e
+  | Error e -> raise e (* TODO: better backtraces? *)
 
 (** Let-syntax for {!with_context} *)
 let ( let< ) = with_context
@@ -52,3 +52,29 @@ let sigprocmask mode sigs : _ t = fun k ->
   let result = k () in
   Unix.sigprocmask Unix.SIG_SETMASK prev_mask |> (ignore : int list -> _);
   result
+
+let timeout_unix ?timer t : _ t = fun k ->
+  match Util.timeout_unix ?timer t k () with
+  | None -> Ok None
+  | Some r -> Result.map Option.some r
+
+let timed : _ t = fun k ->
+  match Util.timed k () with
+  | Error _ as e, _ -> e
+  | Ok r, t -> Ok (r, t)
+
+let capture_exceptions ?(filter = Fun.const true) () : _ t = fun k ->
+  match k () with
+  | Ok x -> Ok (Ok x)
+  | Error e when filter e -> Ok (Error e)
+  | Error e -> Error e
+
+let empty_context x f : _ t = fun k -> Result.map f (k x)
+let empty_context' x : _ t = empty_context x Fun.id
+
+let optional_context ~some x_empty f_empty = function
+  | None -> empty_context x_empty f_empty
+  | Some x -> some x
+
+let optional_timeout_unix ?timeout =
+  optional_context ~some:timeout_unix () Option.some timeout

src/common/p_run.ml

@@ -37,12 +37,19 @@ type phase = Completed | TimedOut | Killed
 
 type result = {
     phase : phase (** What phase was the process in when it completed? *);
-    status : Unix.process_status;
+    status : Unix.process_status (** What status did the process exit with? *);
     stdout : string;
     stderr : string;
     elapsed : Mtime.span;
   }
 
+(** Did the subprocess exit normally? If [check_status] is [false], ignore
+    the exit code and check only for a timeout. *)
+let result_is_ok ?(check_status = true) = function[@warning "-4"]
+  | { phase = Completed; _ } when not check_status -> true
+  | { phase = Completed; status = Unix.WEXITED 0; _ } -> true
+  | _ -> false
+
 let pp_result ?(hide_stdout = false) ?(hide_stderr = false) ?command_line ppf r =
   let open Fmt in
   let open Pp_util in
@@ -66,7 +73,7 @@ let pp_result ?(hide_stdout = false) ?(hide_stderr = false) ?command_line ppf r
   pf ppf "@[<v>@[%a@ %a@ after %a@]%a%a@]"
     (option
       ~none:(const string "A command")
-      (fun ppf -> pf ppf "@[<2>The command @[<2>%a@]@]" (list ~sep:sp @@ pp_of string (* Filename.quote *) Fun.id)))
+      (fun ppf -> pf ppf "@[<2>The command `@[<2>%a@]`@]" (list ~sep:sp @@ pp_of string (* Filename.quote *) Fun.id)))
     command_line
     pp_status (r.phase, r.status)
     Mtime.Span.pp r.elapsed

src/common/path_util.ml

@@ -14,3 +14,7 @@ let is_code ?(condition = FileUtil.True) p =
   if test Is_link p
   then test condition p && test Is_file (Unix.readlink p)
   else test (And (Is_file, condition)) p
+
+let mkdir ?(mode = 0o777) ?(exist_ok = false) p =
+  let open Unix in
+  try mkdir p mode with Unix_error (EEXIST, _, _) when exist_ok -> ()

src/common/util.ml

@@ -12,8 +12,18 @@ let peek f x = f x; x
 (** One-element list. *)
 let singleton x = [x]
 
+let null = function [] -> true | _ -> false
+
+let uncons = function [] -> None | x :: xs -> Some (x, xs)
+
+let unsnoc xs = uncons (List.rev xs) |> Option.map (fun (x, xs) -> List.rev xs, x)
+
 let or_option o1 o2 = o1 |> Option.(fold ~some ~none:o2)
 
+let filter_option f = function Some x as o when f x -> o | _ -> None
+
+let if_option b x = if b then Some x else None
+
 (** [string_contains ~needle haystack]:
     does [needle] exist as a substring of [haystack]?
     Naive {m \mathcal{O}(nm) } implementation. *)

src/test-runner/dune

@@ -0,0 +1,13 @@
+(library
+ (name test_runner)
+ (public_name less-power.test-runner)
+ (libraries
+  common
+  ast_check
+
+  unix
+
+  cmdliner
+  fileutils
+  fmt
+  mtime))

src/test-runner/entry_point.ml

@@ -0,0 +1,97 @@
+(** Entry points for creating test driver executables from a task tree. *)
+
+open Cmdliner
+open Std_task
+
+let build_root =
+  let doc = "Build and run tests relative to this directory." in
+  Arg.(
+    value
+    & opt file Filename.current_dir_name
+    & info ["d"; "build-root"] ~docv:"DIR" ~doc
+  )
+
+let safe =
+  (* TODO: *may* be deleted, and currently aren't *)
+  let doc =
+    "Run tests in 'safe' mode. DANGER: template, solution, \
+    and test repositories may be permanently deleted."
+  in
+  Arg.(value & flag & info ["s"; "safe"] ~doc)
+
+let mtime_s =
+  let open Arg in
+  let parser =
+    parser_of_kind_of_string
+      ~kind:"a number"
+      (fun s ->
+        let float_s = Float.of_string_opt s in
+        let float_ns = float_s |> Option.map (fun fs -> fs *. Mtime.Span.(to_float_ns s)) in
+        Option.bind float_ns Mtime.Span.of_float_ns)
+  in
+  conv ~docv:"SECONDS" (parser, Mtime.Span.pp)
+
+let mk_timeout ~names ~task ~default =
+  let doc = f"Timeout used when %s, in seconds." task in
+  Arg.(value & opt mtime_s default & info names ~doc)
+
+let build_timeout =
+  mk_timeout ~names:[ "build-timeout" ] ~default:Mtime.Span.(1 * min)
+    ~task:"running `dune build` (or similar)"
+
+let probe_timeout =
+  mk_timeout ~names:[ "probe-timeout" ] ~default:Mtime.Span.(10 * s)
+    ~task:"checking submission for long-running top-level code"
+
+let test_timeout =
+  mk_timeout ~names:[ "test-timeout" ] ~default:Mtime.Span.(10 * min)
+    ~task:"running test executable"
+
+(* TODO: timestamp formatting is ugly *)
+let mk_timestamp ~default ~names ~when_ =
+  let doc =
+    f"%s time of the exercise (as a UNIX timestamp, in UTC). \
+    Determines when secret test results are hidden and shown."
+    (String.capitalize_ascii when_)
+  in
+  Arg.(value & opt float default & info names ~doc ~docv:"TIMESTAMP")
+
+let exercise_start =
+  mk_timestamp ~default:(-. max_float)
+    ~names:[ "exercise-start" ] ~when_:"start"
+
+let exercise_end =
+  mk_timestamp ~default:max_float ~names:[ "exercise-end" ] ~when_:"end"
+
+
+let term_of_runner runner =
+  Term.(
+    const runner $ build_root $ safe $ build_timeout $ probe_timeout
+      $ test_timeout $ exercise_start $ exercise_end
+  )
+
+let runner_with_cfg of_cfg build_root safe build_timeout probe_timeout
+    test_timeout exercise_start exercise_end =
+  {
+    build_root; safe; build_timeout; probe_timeout;
+    test_timeout; exercise_start; exercise_end
+  }
+  |> of_cfg
+
+let task_runner task_of_cfg cfg =
+  let open Task in
+  let task : (unit, unit) tree = task_of_cfg cfg in
+  let result, summary = run task () in
+  Format.printf "@[<v>Task summary:@,%a@,%a@]@."
+    (pp_summary ~failure:(Result.is_error result) ()) summary
+    (pp_state_out Fmt.(const string "Build successful.")) result
+
+let command_of_term term =
+  let doc = "test runner" in
+  let info = Cmd.info "test-runner" ~doc in
+  Cmd.v info term
+
+let run_task_main ?(exit = exit) task_of_cfg =
+  let term = term_of_runner (runner_with_cfg (task_runner task_of_cfg)) in
+  let cmd = command_of_term term in
+  Cmd.eval cmd |> exit