move things into separate files

src/test-runner/entry_point.ml

@@ -0,0 +1,108 @@
+(** Entry points for creating test driver executables from a task tree. *)
+
+open Cmdliner
+open Std_task
+
+(* TODO: remove *)
+type 'a runner =
+  build_root:FilePath.filename ->
+  safe:bool ->
+  build_timeout:Mtime.span ->
+  test_timeout:Mtime.span ->
+  probe_timeout:Mtime.span ->
+  exercise_start:float ->
+  exercise_end:float ->
+  'a
+
+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.Task_tree in
+  let task : (unit, unit) t = 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.x) ()) 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

src/test-runner/std_task.ml

@@ -0,0 +1,174 @@
+(** Tasks for the standard test setup. *)
+
+open Task
+open Task.Task_tree
+open Common
+open Ctx_util
+
+let f = Printf.sprintf
+
+module Messages = struct
+  let submission_error =
+    "Unable to build submission: \
+     ensure that your code builds and matches the provided interface"
+  let test_failure =
+    "Error while running tests: \
+     please report this failure to an instructor"
+  let symlink = "Cannot build with symlinks present"
+end
+
+type cfg = {
+  build_root : FilePath.filename (** relative paths are OK *);
+  safe : bool ;
+
+  build_timeout : Mtime.span ;
+  test_timeout : Mtime.span ;
+  probe_timeout : Mtime.span ;
+
+  exercise_start : float (** UTC time *);
+  exercise_end : float (** UTC time *);
+}
+
+let check_contains_symlink cfg p =
+  task1 ~label:(f"check_symlink[%s]" p) @@ fun _ ->
+      if contains_symlink Path_util.(cfg.build_root / p)
+      then fail Messages.symlink
+
+let write_file_pp ?label cfg pp p =
+  task1 ?label @@ fun x ->
+      let< ch = Out_channel.with_open_text Path_util.(cfg.build_root / p) in
+      let ppf = Format.formatter_of_out_channel ch in
+      pp ppf x;
+      Format.pp_print_flush ppf ()
+
+let write_file_f ?label cfg p =
+  Format.kdprintf @@ fun pp ->
+      first_map (Fun.const pp) @@ write_file_pp ?label cfg (Fmt.fmt "%t") p
+
+let write_file_str ?label cfg s p =
+  write_file_pp ?label cfg (fun fmt _ -> Format.pp_print_string fmt s) p
+
+let configure_show_hidden cfg p =
+  let check =
+    task1 @@ fun _ ->
+        cfg.safe &&
+        (let now = Unix.gettimeofday () in (* TODO: is this actually UTC? seems so... *)
+        cfg.exercise_start <= now && now <= cfg.exercise_end)
+  in
+  let write =
+    write_file_pp cfg
+      (fun fmt -> Format.fprintf fmt "let show_hidden = %b")
+      p
+  in
+  group ~label:"configure_show_hidden" (check |> then_ write)
+
+(** Task: remove the files which match [condition] (default: [.ml] files).
+    Not recursive: only files in [p] will be deleted, not in subdirectories. *)
+let remove_files ?(condition = FileUtil.Has_extension "ml") cfg p =
+  task1 (* ?label:(if_option label (f"remove_files[%s]" p)) *) @@ fun _ ->
+      Path_util.readdir_p Path_util.(cfg.build_root / p)
+      |> Seq.iter (fun p1 ->
+          if Path_util.is_code ~condition p1 then Sys.remove p1)
+
+(** Task: copy the files which match [condition] (default: [.ml] files).
+    Not recursive: only files in [src0] will be copied, not in subdirectories. *)
+let copy_files ?(condition = FileUtil.Has_extension "ml") cfg src0 dst0 =
+  task1 (* ~label:(f"copy_code[%s->%s]" src0 dst0) *) @@ fun _ ->
+      let src = Unix.realpath Path_util.(cfg.build_root / src0) in
+      let dst = Path_util.(cfg.build_root / dst0) in
+      Path_util.readdir_p src
+      |> Seq.filter (Path_util.is_code ~condition)
+      |> Seq.iter (fun src_p ->
+          Unix.symlink src_p Path_util.(dst / Filename.basename src_p))
+
+(** Composition of {!remove_files} and {!load_files}. *)
+let load_files cfg ?condition src dst =
+  let rm = remove_files ?condition cfg dst in
+  let cp = (copy_files ?condition cfg src dst) in
+  group (* ~label:(f"load_files[%s->%s]" src dst) *) (rm |> then_ cp)
+
+let make_test_report_directory cfg p =
+  let mk () = Path_util.mkdir ~exist_ok:true Path_util.(cfg.build_root / p) in
+  let rm = remove_files ~condition:(FileUtil.Has_extension "xml") cfg p in
+  group (task1 mk |> then_ rm)
+
+(** Run the {{!module-Ast_check.val-path_violations}AST-checker} as a task. *)
+let checker cfg ?prohibited ?(limit = 3) ?check1 ?check p =
+  task1 ~label:(f"checker[%s]" p) @@ fun _ ->
+      let open Fmt in
+      let buff = Buffer.create 512 in
+      let ppf = Format.formatter_of_buffer buff in
+
+      let violation = ref false in
+      let k = function
+        | [] -> ()
+        | vs ->
+            violation := true;
+            pf ppf "%a" (vbox (list ~sep:cut (box Ast_check.pp_violation))) vs
+      in
+      Ast_check.path_violations
+        ?prohibited ~limit ?check1 ?check k Path_util.(cfg.build_root / p);
+
+      Format.pp_print_flush ppf ();
+      if !violation then
+        failf "%a" buffer buff
+
+(** Run a process as a task *)
+let subprocess_run ?timeout ?args command =
+  task1 @@ fun _ -> P_run.p_run ?timeout ?args command
+
+(** Handle the result of a subprocess task. *)
+let subprocess_result ?hide_stdout ?hide_stderr
+    ?command_line ?error_message ?check_status ?(dump_output = true) () =
+  let open P_run in
+  task1 @@ fun r ->
+      let ok = P_run.result_is_ok r ?check_status in
+      let message =
+        Format.dprintf "@[<v>%a%a@]"
+          (pp_result ?hide_stdout ?hide_stderr ?command_line) r
+          Fmt.(option (cut ++ Pp_util.pp_text))
+          (if ok then None else error_message)
+      in
+      (* TODO: dumping the output should probably happen directly in the
+          subprocess runner, but since that is kept simple, it is currently
+          not supported. *)
+      if dump_output then
+        Format.fprintf Format.err_formatter
+          "@[<v 2>[INFO] subprocess complete:@,%t@]@."
+          message;
+      if ok then r else failf "%t" message
+
+type subprocess_options = {
+  timeout : P_run.timeout_description option;
+  hide_stdout : bool;
+  hide_stderr : bool;
+  error_message : string option;
+  check_status : bool;
+  dump_output : bool;
+}
+
+let subprocess_options ?timeout ?(hide_stdout = false) ?(hide_stderr = false)
+    ?error_message ?(check_status = true) ?(dump_output = true) () =
+  { timeout; hide_stdout; hide_stderr; error_message; check_status; dump_output }
+
+let subprocess cfg ?(options = subprocess_options ()) ?args command =
+  let run = subprocess_run ?timeout:options.timeout ?args command in
+  let result =
+    subprocess_result ()
+      ~hide_stdout:(options.hide_stdout && cfg.safe)
+      ~hide_stderr:(options.hide_stderr && cfg.safe)
+      ~command_line:(command :: Option.value args ~default:[])
+      ?error_message:options.error_message
+      ~check_status:options.check_status
+      ~dump_output:(options.dump_output && not cfg.safe)
+  in
+  group (run |> then_ result)
+
+let dune cfg ?options ~root ?(args = []) cmd =
+  subprocess cfg ?options "opam"
+    ~args:(["exec"; "--"; "dune"; cmd; "--root"; Path_util.(cfg.build_root / root)] @ args)
+
+let timeout_for cfg = function
+  | `Build -> cfg.build_timeout
+  | `Test -> cfg.test_timeout
+  | `Probe -> cfg.probe_timeout