Merge pull request 'only show active jobs, fixes #162' (#176) from orphan-old-builds into main

Reviewed-on: #176

bin/builder_web_app.ml

@@ -113,7 +113,7 @@ let run_batch_viz ~cachedir ~datadir ~configdir =
         m "Error while starting batch-viz.sh: %a"
           Rresult.R.pp_msg err)
 
-let setup_app level influx port host datadir cachedir configdir run_batch_viz_flag =
+let setup_app level influx port host datadir cachedir configdir run_batch_viz_flag expired_jobs =
   let dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in
   let datadir = Fpath.v datadir in
   let cachedir =
@@ -159,7 +159,7 @@ let setup_app level influx port host datadir cachedir configdir run_batch_viz_fl
     let error_handler = Dream.error_template Builder_web.error_template in
     Dream.initialize_log ?level ();
     let dream_routes = Builder_web.(
-        routes ~datadir ~cachedir ~configdir
+        routes ~datadir ~cachedir ~configdir ~expired_jobs
         |> to_dream_routes
       )
     in
@@ -241,11 +241,15 @@ let run_batch_viz =
              log is written to CACHE_DIR/batch-viz.log" in
   Arg.(value & flag & info [ "run-batch-viz" ] ~doc)
 
+let expired_jobs =
+  let doc = "Amount of days after which a job is considered to be inactive if \
+             no successful build has been achieved (use 0 for infinite)" in
+  Arg.(value & opt int 30 & info [ "expired-jobs" ] ~doc)
 
 let () =
   let term =
     Term.(const setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir $
-          cachedir $ configdir $ run_batch_viz)
+          cachedir $ configdir $ run_batch_viz $ expired_jobs)
   in
   let info = Cmd.info "Builder web" ~doc:"Builder web" ~man:[] in
   Cmd.v info term

lib/builder_web.ml

@@ -258,8 +258,17 @@ module Viz_aux = struct
 end
 
 
-let routes ~datadir ~cachedir ~configdir =
-  let builds req =
+let routes ~datadir ~cachedir ~configdir ~expired_jobs =
+  let builds ~all ?(filter_builds_later_than = 0) req =
+    let than =
+      if filter_builds_later_than = 0 then
+        Ptime.epoch
+      else
+        let n = Ptime.Span.v (filter_builds_later_than, 0L) in
+        let now = Ptime_clock.now () in
+        Ptime.Span.sub (Ptime.to_span now) n |> Ptime.of_span |>
+        Option.fold ~none:Ptime.epoch ~some:Fun.id
+    in
     Dream.sql req Model.jobs_with_section_synopsis
     |> if_error "Error getting jobs"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
@@ -272,20 +281,26 @@ let routes ~datadir ~cachedir ~configdir =
            r >>= fun acc ->
            Dream.sql req (Model.build_with_main_binary job_id platform) >>= function
            | Some (build, artifact) ->
-             Lwt_result.return ((platform, build, artifact) :: acc)
+             if Ptime.is_later ~than build.finish then
+               Lwt_result.return ((platform, build, artifact) :: acc)
+             else
+               Lwt_result.return acc
            | None ->
              Log.warn (fun m -> m "Job without builds: %s" job_name);
              Lwt_result.return acc)
            ps (Lwt_result.return []) >>= fun platform_builds ->
-         let v = (job_name, synopsis, platform_builds) in
-         let section = Option.value ~default:"Uncategorized" section in
-         Lwt_result.return (Utils.String_map.add_or_create section v acc))
+         if platform_builds = [] then
+           Lwt_result.return acc
+         else
+           let v = (job_name, synopsis, platform_builds) in
+           let section = Option.value ~default:"Uncategorized" section in
+           Lwt_result.return (Utils.String_map.add_or_create section v acc))
       jobs
       (Lwt_result.return Utils.String_map.empty)
     |> if_error "Error getting jobs"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
     >>= fun jobs ->
-    Views.Builds.make jobs |> string_of_html |> Dream.html |> Lwt_result.ok
+    Views.Builds.make ~all jobs |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
   let job req =
@@ -605,7 +620,7 @@ let routes ~datadir ~cachedir ~configdir =
   let w f req = or_error_response (f req) in
 
   [
-    `Get, "/", (w builds);
+    `Get, "/", (w (builds ~all:false ~filter_builds_later_than:expired_jobs));
     `Get, "/job/:job", (w job);
     `Get, "/job/:job/failed", (w job_with_failed);
     `Get, "/job/:job/build/latest/**", (w redirect_latest);
@@ -619,6 +634,7 @@ let routes ~datadir ~cachedir ~configdir =
     `Get, "/job/:job/build/:build/console", (w (job_build_static_file `Console));
     `Get, "/job/:job/build/:build/all.tar.gz", (w job_build_targz);
     `Get, "/failed-builds", (w failed_builds);
+    `Get, "/all-builds", (w (builds ~all:true));
     `Get, "/hash", (w hash);
     `Get, "/compare/:build_left/:build_right", (w compare_builds);
     `Post, "/upload", (Authorization.authenticate (w upload));

lib/views.ml

@@ -361,14 +361,23 @@ have questions or suggestions.
           H.txt "View the latest failed builds ";
           H.a ~a:H.[a_href "/failed-builds"]
             [H.txt "here"];
-          H.txt "."
+          H.txt ".";
         ]]
 
-  let make section_job_map =
+  let make_all_or_active all =
+      [ H.p [
+            H.txt (if all then "View active jobs " else "View all jobs ");
+            H.a ~a:H.[a_href (if all then "/" else "/all-builds")]
+              [H.txt "here"];
+            H.txt ".";
+          ]]
+
+  let make ~all section_job_map =
     layout ~title:"Reproducible OPAM builds"
       (make_header
        @ make_body section_job_map
-       @ make_failed_builds)
+       @ make_failed_builds
+       @ make_all_or_active all)
 
 end
 

test/router.ml

@@ -59,7 +59,7 @@ let router =
    * in the handlers which are never called here. The path /nonexistant is
    * assumed to not exist. *)
   let nodir = Fpath.v "/nonexistant" in
-  Builder_web.routes ~datadir:nodir ~cachedir:nodir ~configdir:nodir
+  Builder_web.routes ~datadir:nodir ~cachedir:nodir ~configdir:nodir ~expired_jobs:0
   |> List.map (fun (meth, route, _handler) ->
       meth, route, Param_verification.verify (find_parameters route))
   |> Builder_web.to_dream_routes