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

Reviewed-on: #176

bin/builder_web_app.ml

@@ -81,28 +81,28 @@ let init_influx name data =
 let run_batch_viz ~cachedir ~datadir ~configdir =
   let open Rresult.R.Infix in
   begin
-    let script = Fpath.(configdir / "batch-viz.sh") 
+    let script = Fpath.(configdir / "batch-viz.sh")
     and script_log = Fpath.(cachedir / "batch-viz.log")
-    and viz_script = Fpath.(configdir / "upload-hooks" / "visualizations.sh") 
+    and viz_script = Fpath.(configdir / "upload-hooks" / "visualizations.sh")
     in
     Bos.OS.File.exists script >>= fun script_exists ->
     if not script_exists then begin
       Logs.warn (fun m -> m "Didn't find %s" (Fpath.to_string script));
       Ok ()
     end else
-      let args = 
+      let args =
         [ "--cache-dir=" ^ Fpath.to_string cachedir;
           "--data-dir=" ^ Fpath.to_string datadir;
           "--viz-script=" ^ Fpath.to_string viz_script ]
         |> List.map (fun s -> "\"" ^ String.escaped s ^ "\"")
         |> String.concat " "
       in
-      (*> Note: The reason for appending, is that else a new startup could 
+      (*> Note: The reason for appending, is that else a new startup could
           overwrite an existing running batch's log*)
       (Fpath.to_string script ^ " " ^ args
        ^ " 2>&1 >> " ^ Fpath.to_string script_log
        ^ " &")
-      |> Sys.command 
+      |> Sys.command
       |> ignore
       |> Result.ok
   end
@@ -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 routes ~datadir ~cachedir ~configdir ~expired_jobs =
-  let builds req =
+  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
+         if platform_builds = [] then
-         let section = Option.value ~default:"Uncategorized" section in
+           Lwt_result.return acc
-         Lwt_result.return (Utils.String_map.add_or_create section v 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

@@ -98,7 +98,7 @@ let make_breadcrumbs nav =
       txtf "Job %s" job_name, Link.Job.make ~job_name ();
       (
         txtf "%a" pp_platform platform,
-        Link.Job.make ~job_name ~queries () 
+        Link.Job.make ~job_name ~queries ()
       )
     ]
   | `Build (job_name, build) ->
@@ -122,7 +122,7 @@ let make_breadcrumbs nav =
         txtf "Comparison between %s@%a and %s@%a"
           job_left pp_ptime build_left.Builder_db.Build.start
           job_right pp_ptime build_right.Builder_db.Build.start,
-        Link.Compare_builds.make 
+        Link.Compare_builds.make
           ~left:build_left.uuid
           ~right:build_right.uuid ()
       );
@@ -218,7 +218,7 @@ let page_not_found ~target ~referer =
     | None -> []
     | Some prev_url -> [
         H.p [
-          H.txt "Go back to "; 
+          H.txt "Go back to ";
           H.a ~a:H.[ a_href prev_url ] [ H.txt prev_url ];
         ];
       ]
@@ -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
 
@@ -393,7 +402,7 @@ module Job = struct
         check_icon build.Builder_db.Build.result;
         txtf " %s " build.platform;
         H.a ~a:H.[
-            a_href @@ Link.Job_build.make 
+            a_href @@ Link.Job_build.make
               ~job_name
               ~build:build.Builder_db.Build.uuid () ]
           [
@@ -431,7 +440,7 @@ module Job = struct
           H.txt "." ]
       else
         H.p [
-          H.txt "Including failed builds " ; 
+          H.txt "Including failed builds " ;
           H.a ~a:H.[
               a_href @@ Link.Job.make_failed ~job_name ~queries ()
             ]
@@ -582,7 +591,7 @@ module Job_build = struct
         | Some b when not (Uuidm.equal build.uuid b.Builder_db.Build.uuid) ->
           [ H.li [ H.txt ctx;
                    H.a ~a:[
-                     H.a_href @@ Link.Compare_builds.make 
+                     H.a_href @@ Link.Compare_builds.make
                        ~left:b.uuid
                        ~right:build.uuid () ]
                      [txtf "%a" pp_ptime b.start]]
@@ -679,10 +688,10 @@ module Job_build = struct
           font-weight: bold;\
           "
       ]
-  
+
   let make_viz_section ~job_name ~artifacts ~uuid =
-    let viz_deps = 
+    let viz_deps =
-      let iframe = 
+      let iframe =
         let src = Link.Job_build_artifact.make ~job_name ~build:uuid
             ~artifact:`Viz_dependencies () in
         H.iframe ~a:H.[
@@ -693,11 +702,11 @@ module Job_build = struct
       in
       let descr_txt = "\
 This is an interactive visualization of dependencies, \
-focusing on how shared dependencies are. 
+focusing on how shared dependencies are.
 
 In the middle you see the primary package. \
 Edges shoot out to its direct \
-dependencies, including build dependencies. 
+dependencies, including build dependencies.
 
 From these direct dependencies, edges shoot out to sets \
 of their own respective direct dependencies. \
@@ -714,7 +723,7 @@ dependency.\
       [ iframe; H.br (); make_description descr_txt ]
     in
     let viz_treemap = lazy (
-      let iframe = 
+      let iframe =
         let src = Link.Job_build_artifact.make ~job_name ~build:uuid
             ~artifact:`Viz_treemap () in
         H.iframe ~a:H.[
@@ -726,7 +735,7 @@ dependency.\
       let descr_txt = "\
 This interactive treemap shows the space-usage of modules/libraries inside the \
 ELF binary. You can get more info from each block by \
-hovering over them. 
+hovering over them.
 
 On top of the treemap there is a scale, showing how much space the \
 treemap itself constitutes of the binary, the excluded symbols/modules \

test/router.ml

@@ -2,7 +2,7 @@
 module Param_verification = struct
 
   (*> None is 'verified'*)
-  type t = wrong_type option 
+  type t = wrong_type option
   [@@deriving yojson,show,eq]
 
   and wrong_type = {
@@ -24,9 +24,9 @@ module Param_verification = struct
           param;
           expected = "Uuidm.t"
         }
-    
+
   end
-  
+
   let verify parameters req =
     let verified_params =
       List.fold_left (fun acc p ->
@@ -53,13 +53,13 @@ let find_parameters path =
       else
         None)
     (String.split_on_char '/' path)
-                   
+
 let router =
   (* XXX: this relies on [Builder_web.routes] only using {data,cache,config}dir
    * 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
@@ -83,7 +83,7 @@ let test_link method_ target () =
   Alcotest.(check' (result Param_verification.alcotyp string) ~msg:"param-verification"
               ~actual:body ~expected:(Ok None))
 
-let test_link_artifact artifact = 
+let test_link_artifact artifact =
   let job_name = "test" in
   let build = Uuidm.v `V4 in
   test_link `GET @@
@@ -147,7 +147,7 @@ let () =
         end;
         test_case "Link.Failed_builds.make" `Quick begin
           test_link `GET @@
-          Builder_web.Link.Failed_builds.make ~count:2 ~start:1 () 
+          Builder_web.Link.Failed_builds.make ~count:2 ~start:1 ()
         end;
       ];
     (* this doesn't actually test the redirects, unfortunately *)