robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

use modulectomy to render svg of the unikernel binaries

Browse source
This commit is contained in:
Robur 2021-12-06 15:40:20 +00:00 committed by Reynir Björnsson
parent 888b4aa8b6
commit 7fa8402eee
3 changed files with 38 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
lib/builder_web.ml
View file

@ -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);

2
lib/dune
View file

@ -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))

2
lib/views.ml
View file

@ -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]