diff --git a/lib/builder_web.ml b/lib/builder_web.ml index a30a2a7..5d7ff6e 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -183,20 +183,29 @@ let add_routes datadir = |> Lwt_result.ok in - let treemap_visualization_cmd ~elf_path ~elf_size = - let builder_viz_cmd = - (*> goto make work across different cwd's*) - let bin = "_build/default/bin/visualizations/builder_viz.exe" in - bin, [| bin; "treemap"; elf_path; Int.to_string elf_size |] + let visualization_cmd args = + (*> goto make work across different cwd's*) + let bin = "_build/default/bin/visualizations/builder_viz.exe" in + let cmd = bin, Array.of_list (bin :: args) in - Lwt_process.pread ~stderr:`Dev_null builder_viz_cmd + Lwt_process.pread ~stderr:`Dev_null cmd |> Lwt_result.catch |> Lwt_result.map_err (fun exn -> Printexc.to_string exn, `Internal_Server_Error ) in + + let treemap_visualization_cmd ~elf_path ~elf_size = + [ "treemap"; elf_path; Int.to_string elf_size ] + |> visualization_cmd + in + + let dependencies_visualization_cmd ~opam_switch_path = + [ "dependencies"; opam_switch_path ] + |> visualization_cmd + in - let job_build_treemap req = + let job_build_viztreemap req = let _job_name = Dream.param "job" req and build = Dream.param "build" req in get_uuid build >>= fun uuid -> @@ -224,6 +233,26 @@ let add_routes datadir = Lwt_result.ok (Dream.html svg_html) in + let job_build_vizdependencies req = + let _job_name = Dream.param "job" req + and build = Dream.param "build" req in + get_uuid build >>= fun uuid -> + ( + let opam_switch_path = Fpath.(v "opam-switch") in + Dream.sql req (Model.build_artifact uuid opam_switch_path) + ) + |> if_error "Error getting job build" + ~log:(fun e -> Log.warn (fun m -> m "Error getting job data: %a" pp_error e)) + >>= fun opam_switch -> + let datadir = Dream.global datadir_global req in + let opam_switch_path = Fpath.( + datadir // opam_switch.Builder_db.localpath + |> to_string + ) in + dependencies_visualization_cmd ~opam_switch_path >>= fun svg_html -> + Lwt_result.ok (Dream.html svg_html) + in + let job_build req = let job_name = Dream.param "job" req and build = Dream.param "build" req in @@ -439,7 +468,8 @@ let add_routes datadir = Dream.get "/job/:job/build/:build/" (w job_build); Dream.get "/job/:job/build/:build/f/**" (w job_build_file); Dream.get "/job/:job/build/:build/main-binary" (w redirect_main_binary); - Dream.get "/job/:job/build/:build/treemap" (w job_build_treemap); + Dream.get "/job/:job/build/:build/viztreemap" (w job_build_viztreemap); + Dream.get "/job/:job/build/:build/vizdependencies" (w job_build_vizdependencies); Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script)); Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console)); Dream.get "/failed-builds/" (w failed_builds); diff --git a/lib/views.ml b/lib/views.ml index fab8d3a..f6b681d 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -359,9 +359,13 @@ let job_build let analysis_section = if not @@ contains_debug_bin artifacts then [] else [ h3 [txt "Analysis"]; p [ - let src = Fmt.str "/job/%s/build/%a/treemap" name Uuidm.pp uuid in + let src = Fmt.str "/job/%s/build/%a/viztreemap" name Uuidm.pp uuid in let style = "width: 50em; height: 54.0em" in (*treemap tries to be square*) iframe ~a:[ a_src src; a_title "Binary dissection"; a_style style ] [] ]; + p [ + let src = Fmt.str "/job/%s/build/%a/vizdependencies" name Uuidm.pp uuid in + let style = "width: 50em; height: 54.0em" in + iframe ~a:[ a_src src; a_title "Opam dependencies"; a_style style ] [] ]; ] in let body =