diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 3d88525..f9dc913 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -172,6 +172,40 @@ let add_routes datadir = |> Lwt_result.ok in + let job_build_treemap req = + let _job_name = Dream.param "job" req + and build = Dream.param "build" req in + get_uuid build >>= fun uuid -> + (Dream.sql req (Model.build uuid) >>= fun (id, _build) -> + Dream.sql req (Model.build_artifacts id) >>= fun binaries -> + Model.not_found + (List.find_opt (fun f -> Fpath.has_ext "debug" f.Builder_db.filepath) binaries)) + |> if_error "Error getting job build" + ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e)) + >>= fun binary -> + let datadir = Dream.global datadir_global req in + let path = Fpath.(datadir // binary.Builder_db.localpath) in + let open Modulectomy in + Lwt.return ( + Result.map_error (fun _ -> `File_error path) + (Elf.get (Fpath.to_string path))) + |> if_error "Error reading ELF binary" + ~log:(fun _ -> Log.warn (fun m -> m "Error reading ELF file %a" + Fpath.pp path)) + >>= fun infos -> + let svg = + infos + |> Info.import + |> Info.diff_size + |> Info.prefix_filename + |> Info.cut 2 + |> Treemap.of_tree + |> Treemap.doc + |> Fmt.to_to_string (Tyxml.Html.pp ()) + in + Lwt_result.ok (Dream.html svg) + in + let job_build req = let job_name = Dream.param "job" req and build = Dream.param "build" req in @@ -387,6 +421,7 @@ 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/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/dune b/lib/dune index 5c950f8..5e10f06 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,3 @@ (library (name builder_web) - (libraries builder builder_db dream tyxml bos duration hex caqti-lwt opamdiff ptime.clock.os omd)) + (libraries builder builder_db dream tyxml bos duration hex caqti-lwt opamdiff ptime.clock.os omd modulectomy)) diff --git a/lib/views.ml b/lib/views.ml index 360002c..3da7902 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -350,6 +350,8 @@ let job_build p [txtf "Built on platform %s" platform ]; p [txtf "Build took %a." Ptime.Span.pp delta ]; p [txtf "Execution result: %a." Builder.pp_execution_result result]; + p [a ~a:[Fmt.kstr a_href "/job/%s/build/%a/treemap" name Uuidm.pp uuid] + [txt "Treemap"]]; h3 [txt "Build info"]; ul [ li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp uuid]