From 8dedc8b95bcb03322b4faa005a622cbdd9dc82ce Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 18 Sep 2023 11:07:50 +0200 Subject: [PATCH 1/6] only show active jobs, fixes #162 --- lib/builder_web.ml | 19 ++++++++++++++++--- lib/views.ml | 6 +++++- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 54a3cf0..43f6a06 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -259,7 +259,7 @@ end let routes ~datadir ~cachedir ~configdir = - let builds req = + let builds ~filter_builds_later_than req = 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,7 +272,10 @@ 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:filter_builds_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) @@ -604,8 +607,17 @@ let routes ~datadir ~cachedir ~configdir = let w f req = or_error_response (f req) in + let thirty_days_ago = + let thirty = Ptime.Span.v (30, 0L) in + let now = Ptime_clock.now () in + Ptime.Span.sub (Ptime.to_span now) thirty |> Ptime.of_span |> + Option.fold + ~none:Ptime.epoch + ~some:Fun.id + in + [ - `Get, "/", (w builds); + `Get, "/", (w (builds ~filter_builds_later_than:thirty_days_ago)); `Get, "/job/:job", (w job); `Get, "/job/:job/failed", (w job_with_failed); `Get, "/job/:job/build/latest/**", (w redirect_latest); @@ -619,6 +631,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 ~filter_builds_later_than:Ptime.epoch)); `Get, "/hash", (w hash); `Get, "/compare/:build_left/:build_right", (w compare_builds); `Post, "/upload", (Authorization.authenticate (w upload)); diff --git a/lib/views.ml b/lib/views.ml index a800402..63e4b44 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -361,7 +361,11 @@ 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 "."; + H.txt "View all jobs "; + H.a ~a:H.[a_href "/all-builds"] + [H.txt "here"]; + H.txt "."; ]] let make section_job_map = From 95b485617995a915bc5db0105239b9cc9806fb70 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 18 Sep 2023 11:37:02 +0200 Subject: [PATCH 2/6] skip jobs with no builds --- lib/builder_web.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 43f6a06..a09d889 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -280,9 +280,12 @@ let routes ~datadir ~cachedir ~configdir = 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" From 848186bd1a787fbfaf7e6329e59e5122ed9c6bae Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 18 Sep 2023 12:12:42 +0200 Subject: [PATCH 3/6] make the expiry of jobs configurable via cli (default 30) --- bin/builder_web_app.ml | 10 +++++++--- lib/builder_web.ml | 21 ++++++++++++--------- test/router.ml | 2 +- 3 files changed, 20 insertions(+), 13 deletions(-) diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 3fe65fa..22c4151 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index a09d889..c70b4a3 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -258,7 +258,7 @@ module Viz_aux = struct end -let routes ~datadir ~cachedir ~configdir = +let routes ~datadir ~cachedir ~configdir ~expired_jobs = let builds ~filter_builds_later_than req = Dream.sql req Model.jobs_with_section_synopsis |> if_error "Error getting jobs" @@ -610,17 +610,20 @@ let routes ~datadir ~cachedir ~configdir = let w f req = or_error_response (f req) in - let thirty_days_ago = - let thirty = Ptime.Span.v (30, 0L) in - let now = Ptime_clock.now () in - Ptime.Span.sub (Ptime.to_span now) thirty |> Ptime.of_span |> - Option.fold - ~none:Ptime.epoch - ~some:Fun.id + let n_days_ago = + if expired_jobs = 0 then + Ptime.epoch + else + let n = Ptime.Span.v (expired_jobs, 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 [ - `Get, "/", (w (builds ~filter_builds_later_than:thirty_days_ago)); + `Get, "/", (w (builds ~filter_builds_later_than:n_days_ago)); `Get, "/job/:job", (w job); `Get, "/job/:job/failed", (w job_with_failed); `Get, "/job/:job/build/latest/**", (w redirect_latest); diff --git a/test/router.ml b/test/router.ml index 33e45c8..b3eaccd 100644 --- a/test/router.ml +++ b/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 From a9799f4ca8d193bb27ff93af3033d6378adea29d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 18 Sep 2023 12:23:58 +0200 Subject: [PATCH 4/6] delay computation to when the request lands --- lib/builder_web.ml | 29 +++++++++++++---------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index c70b4a3..fdb73d1 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -259,7 +259,16 @@ end let routes ~datadir ~cachedir ~configdir ~expired_jobs = - let builds ~filter_builds_later_than req = + let builds ?(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,7 +281,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs = r >>= fun acc -> Dream.sql req (Model.build_with_main_binary job_id platform) >>= function | Some (build, artifact) -> - if Ptime.is_later ~than:filter_builds_later_than build.finish then + if Ptime.is_later ~than build.finish then Lwt_result.return ((platform, build, artifact) :: acc) else Lwt_result.return acc @@ -610,20 +619,8 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs = let w f req = or_error_response (f req) in - let n_days_ago = - if expired_jobs = 0 then - Ptime.epoch - else - let n = Ptime.Span.v (expired_jobs, 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 - [ - `Get, "/", (w (builds ~filter_builds_later_than:n_days_ago)); + `Get, "/", (w (builds ~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); @@ -637,7 +634,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs = `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 ~filter_builds_later_than:Ptime.epoch)); + `Get, "/all-builds", (w builds); `Get, "/hash", (w hash); `Get, "/compare/:build_left/:build_right", (w compare_builds); `Post, "/upload", (Authorization.authenticate (w upload)); From bfa06c95f8ec6dc7b682a4f5c892c7ffd45233a5 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 18 Sep 2023 12:13:05 +0200 Subject: [PATCH 5/6] whitespace-cleanup --- bin/builder_web_app.ml | 10 +++++----- lib/views.ml | 26 +++++++++++++------------- test/router.ml | 12 ++++++------ 3 files changed, 24 insertions(+), 24 deletions(-) diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 22c4151..fb53cb8 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/lib/views.ml b/lib/views.ml index 63e4b44..ea4c754 100644 --- a/lib/views.ml +++ b/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 ]; ]; ] @@ -397,7 +397,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 () ] [ @@ -435,7 +435,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 () ] @@ -586,7 +586,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]] @@ -683,10 +683,10 @@ module Job_build = struct font-weight: bold;\ " ] - + let make_viz_section ~job_name ~artifacts ~uuid = - let viz_deps = - let iframe = + let viz_deps = + let iframe = let src = Link.Job_build_artifact.make ~job_name ~build:uuid ~artifact:`Viz_dependencies () in H.iframe ~a:H.[ @@ -697,11 +697,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. \ @@ -718,7 +718,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.[ @@ -730,7 +730,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 \ diff --git a/test/router.ml b/test/router.ml index b3eaccd..1cafd5a 100644 --- a/test/router.ml +++ b/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,7 +53,7 @@ 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 @@ -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 *) From 378f5c453891033d44f598ea9088dfe7309ce578 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Tue, 19 Sep 2023 12:07:38 +0200 Subject: [PATCH 6/6] UI enhancement: all/active build modal When showing the active builds link to all builds and vice versa. --- lib/builder_web.ml | 8 ++++---- lib/views.ml | 17 +++++++++++------ 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index fdb73d1..4a40dcf 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -259,7 +259,7 @@ end let routes ~datadir ~cachedir ~configdir ~expired_jobs = - let builds ?(filter_builds_later_than = 0) req = + let builds ~all ?(filter_builds_later_than = 0) req = let than = if filter_builds_later_than = 0 then Ptime.epoch @@ -300,7 +300,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs = |> 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 = @@ -620,7 +620,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs = let w f req = or_error_response (f req) in [ - `Get, "/", (w (builds ~filter_builds_later_than:expired_jobs)); + `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); @@ -634,7 +634,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs = `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); + `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)); diff --git a/lib/views.ml b/lib/views.ml index ea4c754..4de7a2f 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -362,17 +362,22 @@ have questions or suggestions. H.a ~a:H.[a_href "/failed-builds"] [H.txt "here"]; H.txt "."; - H.txt "View all jobs "; - H.a ~a:H.[a_href "/all-builds"] - [H.txt "here"]; - 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