Reviewed-on: #176
This commit is contained in:
commit
46f93c28ea
4 changed files with 68 additions and 39 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
41
lib/views.ml
41
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 \
|
||||
|
|
|
|||
|
|
@ -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 *)
|
||||
|
|
|
|||
Loading…
Reference in a new issue