diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 3fe65fa..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 @@ -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 54a3cf0..4a40dcf 100644 --- a/lib/builder_web.ml +++ b/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)); diff --git a/lib/views.ml b/lib/views.ml index a800402..4de7a2f 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 ]; ]; ] @@ -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 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.[ @@ -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 \ diff --git a/test/router.ml b/test/router.ml index 33e45c8..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,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 *)