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

Safer Lwt_process usage for calling builder-viz cmd (#71)

Browse source 
Co-authored-by: Reynir Björnsson <reynir@reynir.dk>
Co-authored-by: rand00 <oth.rand@gmail.com>
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/71
Co-authored-by: rand <rand@r7p5.earth>
Co-committed-by: rand <rand@r7p5.earth>
This commit is contained in:
rand 2022-02-02 14:50:44 +00:00 committed by Reynir Björnsson
parent 6a645b7358
commit f3aa2a2c90
1 changed files with 23 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
lib/builder_web.ml
View file

@ -4,6 +4,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Lwt.Syntax open Lwt.Syntax
open Lwt_result.Infix open Lwt_result.Infix
let sprintf = Printf.sprintf
let pp_error ppf = function let pp_error ppf = function
| #Caqti_error.connect as e -> Caqti_error.pp ppf e | #Caqti_error.connect as e -> Caqti_error.pp ppf e
| #Model.error as e -> Model.pp_error ppf e | #Model.error as e -> Model.pp_error ppf e
@ -184,15 +186,22 @@ let add_routes datadir =
in in
let visualization_cmd args = let visualization_cmd args =
let cmd = "", Array.of_list ("builder-viz" :: args) let cmd_list = "builder-viz" :: args in
in let cmd = "", Array.of_list cmd_list in
Lwt_process.pread cmd let pin =
~stderr:`Dev_null Lwt_process.open_process_in
~stdin:`Dev_null ~stderr:`Dev_null
~timeout:15. ~timeout:15.
|> Lwt_result.catch cmd
|> Lwt_result.map_err (fun exn -> in
Printexc.to_string exn, `Internal_Server_Error let* output = Lwt_io.read pin#stdout
) and* exit_status = pin#status in
match exit_status with
| Unix.WEXITED 0 -> Lwt_result.return output
| Unix.WEXITED _ | Unix.WSIGNALED _ |Unix.WSTOPPED _ ->
let cmd_str = String.concat " " cmd_list in
`Msg (sprintf "Error when running cmd: '%s'" cmd_str)
|> Lwt_result.fail
in in
let treemap_visualization_cmd ~debug_elf_path ~elf_size = let treemap_visualization_cmd ~debug_elf_path ~elf_size =
@ -226,8 +235,9 @@ let add_routes datadir =
datadir // debug_binary.Builder_db.localpath datadir // debug_binary.Builder_db.localpath
|> to_string |> to_string
) in ) in
treemap_visualization_cmd ~debug_elf_path ~elf_size >>= fun svg_html -> treemap_visualization_cmd ~debug_elf_path ~elf_size
(* Lwt_result.ok (dream_svg svg) *) |> if_error "Failed to generate treemap visualization"
>>= fun svg_html ->
Lwt_result.ok (Dream.html svg_html) Lwt_result.ok (Dream.html svg_html)
in in
@ -245,7 +255,9 @@ let add_routes datadir =
datadir // opam_switch.Builder_db.localpath datadir // opam_switch.Builder_db.localpath
|> to_string |> to_string
) in ) in
dependencies_visualization_cmd ~opam_switch_path >>= fun svg_html -> dependencies_visualization_cmd ~opam_switch_path
|> if_error "Failed to generate dependencies visualization"
>>= fun svg_html ->
Lwt_result.ok (Dream.html svg_html) Lwt_result.ok (Dream.html svg_html)
in in