Automatic viz migration on builder-web startup (#111)
Co-authored-by: rand00 <oth.rand@gmail.com> Reviewed-on: https://git.robur.io/robur/builder-web/pulls/111 Co-authored-by: Reynir Björnsson <reynir@reynir.dk> Co-committed-by: Reynir Björnsson <reynir@reynir.dk>
This commit is contained in:
parent
88c91c0856
commit
09a180c3cd
10 changed files with 490 additions and 317 deletions
|
|
@ -78,7 +78,42 @@ let init_influx name data =
|
|||
in
|
||||
Lwt.async report
|
||||
|
||||
let setup_app level influx port host datadir cachedir configdir =
|
||||
let run_batch_viz ~cachedir ~datadir ~configdir =
|
||||
let open Rresult.R.Infix in
|
||||
begin
|
||||
let script = Fpath.(configdir / "batch-viz.sh")
|
||||
and script_log = Fpath.(cachedir / "batch-viz.log")
|
||||
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 =
|
||||
[ "--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
|
||||
overwrite an existing running batch's log*)
|
||||
(Fpath.to_string script ^ " " ^ args
|
||||
^ " 2>&1 >> " ^ Fpath.to_string script_log
|
||||
^ " &")
|
||||
|> Sys.command
|
||||
|> ignore
|
||||
|> Result.ok
|
||||
end
|
||||
|> function
|
||||
| Ok () -> ()
|
||||
| Error err ->
|
||||
Logs.warn (fun m ->
|
||||
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 dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in
|
||||
let datadir = Fpath.v datadir in
|
||||
let cachedir =
|
||||
|
|
@ -86,6 +121,10 @@ let setup_app level influx port host datadir cachedir configdir =
|
|||
in
|
||||
let configdir = Fpath.v configdir in
|
||||
let () = init_influx "builder-web" influx in
|
||||
let () =
|
||||
if run_batch_viz_flag then
|
||||
run_batch_viz ~cachedir ~datadir ~configdir
|
||||
in
|
||||
match Builder_web.init dbpath datadir with
|
||||
| Error (#Caqti_error.load as e) ->
|
||||
Format.eprintf "Error: %a\n%!" Caqti_error.pp e;
|
||||
|
|
@ -140,19 +179,28 @@ let ip_port : (Ipaddr.V4.t * int) Arg.conv =
|
|||
|
||||
let datadir =
|
||||
let doc = "data directory" in
|
||||
Arg.(value & opt dir Builder_system.default_datadir & info [ "d"; "datadir" ] ~doc)
|
||||
let docv = "DATA_DIR" in
|
||||
Arg.(
|
||||
value &
|
||||
opt dir Builder_system.default_datadir &
|
||||
info [ "d"; "datadir" ] ~doc ~docv
|
||||
)
|
||||
|
||||
let cachedir =
|
||||
let doc = "cache directory" in
|
||||
let docv = "CACHE_DIR" in
|
||||
Arg.(
|
||||
value
|
||||
& opt (some ~none:"DATADIR/_cache" dir) None
|
||||
& info [ "cachedir" ] ~doc
|
||||
)
|
||||
& info [ "cachedir" ] ~doc ~docv)
|
||||
|
||||
let configdir =
|
||||
let doc = "config directory" in
|
||||
Arg.(value & opt dir Builder_system.default_configdir & info [ "c"; "configdir" ] ~doc)
|
||||
let docv = "CONFIG_DIR" in
|
||||
Arg.(
|
||||
value &
|
||||
opt dir Builder_system.default_configdir &
|
||||
info [ "c"; "configdir" ] ~doc ~docv)
|
||||
|
||||
let port =
|
||||
let doc = "port" in
|
||||
|
|
@ -163,13 +211,25 @@ let host =
|
|||
Arg.(value & opt string "0.0.0.0" & info [ "h"; "host" ] ~doc)
|
||||
|
||||
let influx =
|
||||
let doc = "IP address and port (default: 8094) to report metrics to in influx line protocol" in
|
||||
Arg.(value & opt (some ip_port) None & info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]")
|
||||
let doc = "IP address and port (default: 8094) to report metrics to \
|
||||
influx line protocol" in
|
||||
Arg.(
|
||||
value &
|
||||
opt (some ip_port) None &
|
||||
info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]")
|
||||
|
||||
let run_batch_viz =
|
||||
let doc = "Run CONFIG_DIR/batch-viz.sh on startup. \
|
||||
Note that this is started in the background - so the user \
|
||||
is in charge of not running several instances of this. A \
|
||||
log is written to CACHE_DIR/batch-viz.log" in
|
||||
Arg.(value & flag & info [ "run-batch-viz" ] ~doc)
|
||||
|
||||
|
||||
let () =
|
||||
let term =
|
||||
Term.(const setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir $
|
||||
cachedir $ configdir)
|
||||
cachedir $ configdir $ run_batch_viz)
|
||||
in
|
||||
let info = Cmd.info "Builder web" ~doc:"Builder web" ~man:[] in
|
||||
Cmd.v info term
|
||||
|
|
|
|||
|
|
@ -1,175 +0,0 @@
|
|||
let src = Logs.Src.create "builder-viz" ~doc:"Builder_viz"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
open Rresult
|
||||
|
||||
let read_file file =
|
||||
try
|
||||
let fh = open_in file in
|
||||
try
|
||||
let content = really_input_string fh (in_channel_length fh) in
|
||||
close_in_noerr fh ;
|
||||
content
|
||||
with _ ->
|
||||
close_in_noerr fh;
|
||||
invalid_arg ("Error reading file: " ^ file)
|
||||
with _ -> invalid_arg ("Error opening file " ^ file)
|
||||
|
||||
let print_treemap_html elf_path elf_size =
|
||||
let open Modulectomy in
|
||||
let infos =
|
||||
elf_path
|
||||
|> Elf.get
|
||||
|> Result.map_error (fun _ -> R.msg "Invalid ELF file")
|
||||
|> R.failwith_error_msg
|
||||
in
|
||||
let info, excluded_minors =
|
||||
let size, info =
|
||||
infos
|
||||
|> Info.import
|
||||
|> Info.diff_size_tree
|
||||
in
|
||||
(*> Note: this heuristic fails if one has all subtrees of equal size*)
|
||||
let node_big_enough subtree =
|
||||
match Info.(subtree.T.value.size) with
|
||||
| None -> true
|
||||
| Some subtree_size ->
|
||||
let pct = Int64.(to_float subtree_size /. to_float size) in
|
||||
pct > 0.004
|
||||
in
|
||||
info
|
||||
|> Info.prefix_filename
|
||||
|> Info.cut 2
|
||||
|> Info.partition_subtrees node_big_enough
|
||||
in
|
||||
let scale_chunks =
|
||||
let excluded_minors_size =
|
||||
excluded_minors
|
||||
|> List.map Info.compute_area
|
||||
|> List.fold_left Int64.add 0L
|
||||
in
|
||||
[
|
||||
"Smaller excluded entries", excluded_minors_size
|
||||
]
|
||||
in
|
||||
let override_css = {|
|
||||
.treemap-module {
|
||||
fill: rgb(60, 60, 87);
|
||||
}
|
||||
.treemap-functor > text, .treemap-module > text {
|
||||
fill: bisque;
|
||||
}
|
||||
|}
|
||||
in
|
||||
info
|
||||
|> Treemap.of_tree
|
||||
|> Treemap.to_html_with_scale
|
||||
~binary_size:elf_size
|
||||
~scale_chunks
|
||||
~override_css
|
||||
|> Tyxml.Html.pp () Format.std_formatter
|
||||
(* |> Treemap.svg
|
||||
* |> Fmt.to_to_string (Tyxml.Svg.pp ()) *)
|
||||
|
||||
let print_dependencies_html file =
|
||||
let module G = Opam_graph in
|
||||
let switch = read_file file in
|
||||
let data = OpamFile.SwitchExport.read_from_string switch in
|
||||
let graph = G.Ui.dependencies ~transitive:false data in
|
||||
let sharing_stats =
|
||||
data
|
||||
|> G.dependencies ~transitive:false
|
||||
|> G.calc_sharing_stats in
|
||||
let override_css = {|
|
||||
.deps-svg-wrap {
|
||||
background: rgb(60, 60, 87);
|
||||
}
|
||||
|}
|
||||
in
|
||||
let html = G.Render.Html.of_assoc ~override_css ~sharing_stats graph in
|
||||
Format.printf "%a" G.Render.Html.pp html
|
||||
|
||||
module Cmd_aux = struct
|
||||
|
||||
module Arg_aux = struct
|
||||
|
||||
let elf_path =
|
||||
let doc = "The file-path of the debug-ELF to be analyzed" in
|
||||
Cmdliner.Arg.(
|
||||
required &
|
||||
pos 0 (some file) None &
|
||||
info ~doc ~docv:"DEBUG_ELF_PATH" []
|
||||
)
|
||||
|
||||
let elf_size =
|
||||
let doc = "The file-size of the stripped ELF file in bytes" in
|
||||
Cmdliner.Arg.(
|
||||
required &
|
||||
pos 1 (some int) None &
|
||||
info ~doc ~docv:"STRIPPED_ELF_SIZE" []
|
||||
)
|
||||
|
||||
let opam_switch_path =
|
||||
let doc = "The Opam-switch export file of the package to be analyzed" in
|
||||
Cmdliner.Arg.(
|
||||
required &
|
||||
pos 0 (some file) None &
|
||||
info ~doc ~docv:"SWITCH_EXPORT_PATH" []
|
||||
)
|
||||
|
||||
end
|
||||
|
||||
module Aux = struct
|
||||
|
||||
let help man_format cmds = function
|
||||
| None -> `Help (man_format, None)
|
||||
| Some cmd ->
|
||||
if List.mem cmd cmds
|
||||
then `Help (man_format, Some cmd)
|
||||
else `Error (true, "Unknown command: " ^ cmd)
|
||||
|
||||
end
|
||||
|
||||
open Cmdliner
|
||||
|
||||
let treemap =
|
||||
let doc = "Dump treemap SVG and CSS wrapped in HTML" in
|
||||
let term = Term.(const print_treemap_html $ Arg_aux.elf_path $ Arg_aux.elf_size) in
|
||||
let info = Cmd.info ~doc "treemap" in
|
||||
Cmd.v info term
|
||||
|
||||
let dependencies =
|
||||
let doc = "Dump opam dependencies SVG and CSS wrapped in HTML" in
|
||||
let term = Term.(const print_dependencies_html $ Arg_aux.opam_switch_path) in
|
||||
let info = Cmd.info ~doc "dependencies" in
|
||||
Cmd.v info term
|
||||
|
||||
let help =
|
||||
let topic =
|
||||
let doc = "Command to get help on" in
|
||||
Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
|
||||
in
|
||||
let doc = "Builder database help" in
|
||||
let term = Term.(ret (const Aux.help $ Arg.man_format $ choice_names $ topic)) in
|
||||
let info = Cmd.info ~doc "help" in
|
||||
Cmd.v info term
|
||||
|
||||
let default_info, default_cmd =
|
||||
let doc = "Builder database command" in
|
||||
let term = Term.(ret (const Aux.help $ Arg.man_format $ choice_names $ const None)) in
|
||||
let info = Cmd.info ~doc "builder-viz" in
|
||||
info, term
|
||||
|
||||
end
|
||||
|
||||
let () =
|
||||
let open Cmdliner in
|
||||
Cmd.group
|
||||
~default:Cmd_aux.default_cmd Cmd_aux.default_info
|
||||
[
|
||||
Cmd_aux.help;
|
||||
Cmd_aux.treemap;
|
||||
Cmd_aux.dependencies;
|
||||
]
|
||||
|> Cmd.eval
|
||||
|> exit
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
(executable
|
||||
(name builder_viz)
|
||||
(public_name builder-viz)
|
||||
(libraries
|
||||
tyxml bos caqti-lwt cmdliner rresult
|
||||
builder_db
|
||||
modulectomy
|
||||
opam-graph
|
||||
)
|
||||
(flags (:standard (-w -27-26)))
|
||||
)
|
||||
|
||||
|
|
@ -163,48 +163,140 @@ let routes ~datadir ~cachedir ~configdir =
|
|||
|> Lwt_result.ok
|
||||
in
|
||||
|
||||
let redirect_main_binary req =
|
||||
let job_name = Dream.param req "job"
|
||||
and build = Dream.param req "build" in
|
||||
get_uuid build >>= fun uuid ->
|
||||
Dream.sql req (Model.build uuid)
|
||||
let main_binary_of_uuid uuid db =
|
||||
Model.build uuid db
|
||||
|> if_error "Error getting job build"
|
||||
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
|
||||
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
|
||||
>>= fun (_id, build) ->
|
||||
match build.Builder_db.Build.main_binary with
|
||||
| None -> Lwt_result.fail ("Resource not found", `Not_Found)
|
||||
| Some main_binary ->
|
||||
Dream.sql req (Model.build_artifact_by_id main_binary)
|
||||
|> if_error "Error getting main binary" >>= fun main_binary ->
|
||||
Dream.redirect req
|
||||
(Fmt.str "/job/%s/build/%a/f/%a" job_name Uuidm.pp uuid
|
||||
Fpath.pp main_binary.Builder_db.filepath)
|
||||
|> Lwt_result.ok
|
||||
Model.build_artifact_by_id main_binary db
|
||||
|> if_error "Error getting main binary"
|
||||
in
|
||||
|
||||
let try_load_cached_visualization ~cachedir ~uuid typ =
|
||||
let fn = match typ with
|
||||
let redirect_main_binary req =
|
||||
let job_name = Dream.param req "job"
|
||||
and build = Dream.param req "build" in
|
||||
get_uuid build >>= fun uuid ->
|
||||
Dream.sql req (main_binary_of_uuid uuid) >>= fun main_binary ->
|
||||
Dream.redirect req
|
||||
(Fmt.str "/job/%s/build/%a/f/%a" job_name Uuidm.pp uuid
|
||||
Fpath.pp main_binary.Builder_db.filepath)
|
||||
|> Lwt_result.ok
|
||||
in
|
||||
|
||||
let hash_viz_input ~uuid typ db =
|
||||
let open Builder_db in
|
||||
let hex cstruct =
|
||||
let `Hex hex_str = Hex.of_cstruct cstruct in
|
||||
hex_str
|
||||
in
|
||||
main_binary_of_uuid uuid db >>= fun main_binary ->
|
||||
Model.build uuid db
|
||||
|> if_error "Error getting build" >>= fun (build_id, _build) ->
|
||||
Model.build_artifacts build_id db
|
||||
|> if_error "Error getting build artifacts" >>= fun artifacts ->
|
||||
match typ with
|
||||
| `Treemap ->
|
||||
let debug_binary =
|
||||
let bin = Fpath.base main_binary.localpath in
|
||||
List.find_opt
|
||||
(fun p -> Fpath.(equal (bin + "debug") (base p.localpath)))
|
||||
artifacts
|
||||
in
|
||||
begin
|
||||
match debug_binary with
|
||||
| None -> Lwt_result.fail ("Error getting debug-binary", `Not_Found)
|
||||
| Some debug_binary ->
|
||||
debug_binary.sha256
|
||||
|> hex
|
||||
|> Lwt_result.return
|
||||
end
|
||||
| `Dependencies ->
|
||||
let opam_switch =
|
||||
List.find_opt
|
||||
(fun p -> Fpath.(equal (v "opam-switch") (base p.localpath)))
|
||||
artifacts
|
||||
in
|
||||
match opam_switch with
|
||||
| None -> Lwt_result.fail ("Error getting opam-switch", `Not_Found)
|
||||
| Some opam_switch ->
|
||||
opam_switch.sha256
|
||||
|> hex
|
||||
|> Lwt_result.return
|
||||
in
|
||||
|
||||
let get_viz_version ~cachedir ~viz_typ_str =
|
||||
Lwt.return (Bos.OS.Dir.contents cachedir) >>= fun versioned_dirs ->
|
||||
let max_cached_version =
|
||||
let viz_typ_str = viz_typ_str ^ "_" in
|
||||
versioned_dirs
|
||||
|> List.filter_map (fun versioned_dir ->
|
||||
let dir_str = Fpath.filename versioned_dir in
|
||||
if not (String.starts_with ~prefix:viz_typ_str dir_str) then
|
||||
None
|
||||
else
|
||||
try
|
||||
String.(sub dir_str
|
||||
(length viz_typ_str)
|
||||
(length dir_str - length viz_typ_str))
|
||||
|> int_of_string
|
||||
|> Option.some
|
||||
with Failure _ ->
|
||||
Logs.warn (fun m ->
|
||||
m "Failed to read visualization-version from directory: '%s'"
|
||||
(Fpath.to_string versioned_dir));
|
||||
None
|
||||
)
|
||||
|> List.fold_left Int.max (-1)
|
||||
in
|
||||
if max_cached_version = -1 then
|
||||
Lwt_result.fail @@
|
||||
`Msg (Fmt.str "Couldn't find any visualization-version of %s" viz_typ_str)
|
||||
else
|
||||
Lwt_result.return max_cached_version
|
||||
in
|
||||
|
||||
let try_load_cached_visualization ~cachedir ~uuid typ db =
|
||||
let viz_typ_str = match typ with
|
||||
| `Treemap -> "treemap"
|
||||
| `Dependencies -> "dependencies"
|
||||
in
|
||||
let path = Fpath.(cachedir / Uuidm.to_string uuid + fn + "html") in
|
||||
Lwt.return (Bos.OS.File.exists path) >>= fun cached_file_exists ->
|
||||
if not cached_file_exists then
|
||||
Lwt_result.fail (`Msg "Visualization does not exist")
|
||||
else
|
||||
Lwt_result.catch (
|
||||
Lwt_io.with_file ~mode:Lwt_io.Input
|
||||
(Fpath.to_string path)
|
||||
Lwt_io.read
|
||||
) |> Lwt_result.map_err (fun exn -> `Msg (Printexc.to_string exn))
|
||||
get_viz_version ~cachedir ~viz_typ_str
|
||||
|> if_error "Error getting visualization version" >>= fun latest_viz_version ->
|
||||
hash_viz_input ~uuid typ db >>= fun viz_input_hash ->
|
||||
let rec choose_versioned_viz_path current_version =
|
||||
let path = Fpath.(
|
||||
cachedir
|
||||
/ Fmt.str "%s_%d" viz_typ_str current_version
|
||||
/ viz_input_hash + "html"
|
||||
) in
|
||||
Lwt.return (Bos.OS.File.exists path) >>= fun path_exists ->
|
||||
if path_exists then Lwt_result.return path else (
|
||||
if current_version = 1 then
|
||||
Lwt_result.fail (`Msg "There exist no version of the requested visualization")
|
||||
else
|
||||
choose_versioned_viz_path (pred current_version)
|
||||
)
|
||||
in
|
||||
(choose_versioned_viz_path latest_viz_version
|
||||
|> if_error "Error finding a version of the requested visualization")
|
||||
>>= fun viz_path ->
|
||||
Lwt_result.catch (
|
||||
Lwt_io.with_file ~mode:Lwt_io.Input
|
||||
(Fpath.to_string viz_path)
|
||||
Lwt_io.read
|
||||
)
|
||||
|> Lwt_result.map_err (fun exn -> `Msg (Printexc.to_string exn))
|
||||
|> if_error "Error getting cached visualization"
|
||||
in
|
||||
|
||||
let job_build_viz viz_typ req =
|
||||
let _job_name = Dream.param req "job"
|
||||
and build = Dream.param req "build" in
|
||||
get_uuid build >>= fun uuid ->
|
||||
try_load_cached_visualization ~cachedir ~uuid viz_typ
|
||||
|> if_error ~status:`Not_Found "Error getting cached visualization"
|
||||
Dream.sql req (try_load_cached_visualization ~cachedir ~uuid viz_typ)
|
||||
>>= fun svg_html ->
|
||||
Lwt_result.ok (Dream.html svg_html)
|
||||
in
|
||||
|
|
|
|||
15
lib/dune
15
lib/dune
|
|
@ -1,9 +1,18 @@
|
|||
(library
|
||||
(name builder_web)
|
||||
(libraries
|
||||
builder builder_db
|
||||
dream tyxml bos duration hex caqti-lwt
|
||||
opamdiff ptime.clock.os omd tar
|
||||
builder
|
||||
builder_db
|
||||
dream
|
||||
tyxml
|
||||
bos
|
||||
duration
|
||||
hex
|
||||
caqti-lwt
|
||||
opamdiff
|
||||
ptime.clock.os
|
||||
omd
|
||||
tar
|
||||
owee
|
||||
solo5-elftool
|
||||
uri
|
||||
|
|
|
|||
34
lib/model.ml
34
lib/model.ml
|
|
@ -414,40 +414,24 @@ let add_build
|
|||
r;
|
||||
e)) >>= function
|
||||
| None -> Lwt.return (Ok ())
|
||||
| Some p ->
|
||||
let main_binary = p.localpath
|
||||
and `Hex sha256 = Hex.of_cstruct p.sha256
|
||||
and uuid = Uuidm.to_string uuid
|
||||
and time =
|
||||
| Some main_binary ->
|
||||
let time =
|
||||
let (y, m, d), ((hh, mm, ss), _) = Ptime.to_date_time start in
|
||||
Printf.sprintf "%04d%02d%02d%02d%02d%02d" y m d hh mm ss
|
||||
and uuid = Uuidm.to_string uuid
|
||||
and job = job.name
|
||||
and platform = job.platform
|
||||
and debug_binary =
|
||||
let bin = Fpath.base p.localpath in
|
||||
List.find_opt
|
||||
(fun p -> Fpath.(equal (bin + "debug") (base p.localpath)))
|
||||
artifacts |>
|
||||
Option.map (fun p -> p.localpath)
|
||||
and opam_switch =
|
||||
List.find_opt
|
||||
(fun p -> Fpath.(equal (v "opam-switch") (base p.localpath)))
|
||||
artifacts |>
|
||||
Option.map (fun p -> p.localpath)
|
||||
and `Hex sha256 = Hex.of_cstruct main_binary.sha256
|
||||
in
|
||||
let fp_str p = Fpath.(to_string (datadir // p)) in
|
||||
let opt_str ~prefix p =
|
||||
Option.fold ~none:[] ~some:(fun p -> [ "--" ^ prefix ^ "=" ^ fp_str p ]) p
|
||||
in
|
||||
let args =
|
||||
String.concat " "
|
||||
(List.map (fun s -> "\"" ^ String.escaped s ^ "\"")
|
||||
((opt_str ~prefix:"debug-binary" debug_binary) @
|
||||
(opt_str ~prefix:"opam-switch" opam_switch) @
|
||||
[ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ;
|
||||
"--uuid=" ^ uuid ; "--platform=" ^ platform ;
|
||||
"--cache-dir=" ^ Fpath.to_string cachedir ;
|
||||
fp_str main_binary ]))
|
||||
[ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ;
|
||||
"--uuid=" ^ uuid ; "--platform=" ^ platform ;
|
||||
"--cache-dir=" ^ Fpath.to_string cachedir ;
|
||||
"--data-dir=" ^ Fpath.to_string datadir ;
|
||||
fp_str main_binary.localpath ])
|
||||
in
|
||||
Log.debug (fun m -> m "executing hooks with %s" args);
|
||||
let dir = Fpath.(configdir / "upload-hooks") in
|
||||
|
|
|
|||
|
|
@ -31,7 +31,6 @@ install -U $bdir/builder-web $libexecdir/builder-web
|
|||
|
||||
install -U $bdir/builder-migrations $sbindir/builder-migrations
|
||||
install -U $bdir/builder-db $sbindir/builder-db
|
||||
install -U $bdir/builder-viz $sbindir/builder-viz
|
||||
|
||||
# create +MANIFEST
|
||||
flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + |
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
#!/bin/sh
|
||||
|
||||
set -e
|
||||
|
||||
prog_NAME=$(basename "${0}")
|
||||
|
||||
warn()
|
||||
|
|
@ -9,6 +7,11 @@ warn()
|
|||
echo "${prog_NAME}: WARN: $*"
|
||||
}
|
||||
|
||||
info()
|
||||
{
|
||||
echo "${prog_NAME}: INFO: $*"
|
||||
}
|
||||
|
||||
err()
|
||||
{
|
||||
echo "${prog_NAME}: ERROR: $*" 1>&2
|
||||
|
|
@ -23,37 +26,148 @@ die()
|
|||
usage()
|
||||
{
|
||||
cat <<EOM 1>&2
|
||||
usage: ${prog_NAME} [ OPTIONS ] DATADIR
|
||||
usage: ${prog_NAME} [ OPTIONS ]
|
||||
Generates visualizations of all things
|
||||
--data-dir=STRING
|
||||
Path to the data directory.
|
||||
--cache-dir=STRING
|
||||
Optional path to the cache directory. Defaults to DATA_DIR/_cache
|
||||
--viz-script=STRING
|
||||
Optional path to the visualizations.sh script. Defaults to ./visualizations.sh
|
||||
--ignore-done
|
||||
Optional flag to force script to ignore '.done' files
|
||||
EOM
|
||||
exit 1
|
||||
}
|
||||
|
||||
if [ $# -ne 1 ]; then
|
||||
usage
|
||||
CACHE_DIR=
|
||||
DATA_DIR=
|
||||
VISUALIZATIONS_CMD="./visualizations.sh"
|
||||
IGNORE_DONE="false"
|
||||
|
||||
while [ $# -gt 0 ]; do
|
||||
OPT="$1"
|
||||
|
||||
case "${OPT}" in
|
||||
--cache-dir=*)
|
||||
CACHE_DIR="${OPT##*=}"
|
||||
;;
|
||||
--data-dir=*)
|
||||
DATA_DIR="${OPT##*=}"
|
||||
;;
|
||||
--viz-script=*)
|
||||
VISUALIZATIONS_CMD="${OPT##*=}"
|
||||
;;
|
||||
--ignore-done)
|
||||
IGNORE_DONE="true"
|
||||
;;
|
||||
--*)
|
||||
warn "Ignoring unknown option: '${OPT}'"
|
||||
;;
|
||||
*)
|
||||
err "Unknown option: '${OPT}'"
|
||||
usage
|
||||
;;
|
||||
esac
|
||||
shift
|
||||
done
|
||||
|
||||
[ -z "$DATA_DIR" ] && die "The --data-dir option must be specified"
|
||||
|
||||
DB="${DATA_DIR}/builder.sqlite3"
|
||||
[ ! -e "$DB" ] && die "The database doesn't exist: '$DB'"
|
||||
|
||||
DB_VERSION="$(sqlite3 "$DB" "PRAGMA user_version;")"
|
||||
[ -z "$DB_VERSION" ] && die "Couldn't read database version from '$DB'"
|
||||
[ "$DB_VERSION" -lt 16 ] && die "The database version should be >= 16. It is '$DB_VERSION'"
|
||||
|
||||
APP_ID="$(sqlite3 "$DB" "PRAGMA application_id;")"
|
||||
[ -z "$APP_ID" ] && die "Couldn't read application-id from '$DB'"
|
||||
[ "$APP_ID" -ne 1234839235 ] && die "The application-id should be = 1234839235. It is '$APP_ID'"
|
||||
|
||||
echo
|
||||
echo "-----------------------------------------------------------------------------"
|
||||
info "Starting batch creation of visualizations: $(date)"
|
||||
|
||||
if [ -z "$CACHE_DIR" ]; then
|
||||
CACHE_DIR="${DATA_DIR}/_cache"
|
||||
info "Defaulting --cache-dir to '$CACHE_DIR'"
|
||||
fi
|
||||
if [ ! -d "${CACHE_DIR}" ]; then
|
||||
info "Cache directory '$CACHE_DIR' doesn't exist, so it will be made"
|
||||
if ! mkdir "${CACHE_DIR}"; then
|
||||
die "Couldn't make cache directory: '$CACHE_DIR'"
|
||||
fi
|
||||
fi
|
||||
|
||||
DIR="${1}"
|
||||
[ ! -e "${VISUALIZATIONS_CMD}" ] && die "'$VISUALIZATIONS_CMD' doesn't exist"
|
||||
if [ -f "${VISUALIZATIONS_CMD}" ] && [ -x "${VISUALIZATIONS_CMD}" ]; then :; else
|
||||
die "'$VISUALIZATIONS_CMD' is not an executable"
|
||||
fi
|
||||
|
||||
CACHE="${DIR}/_cache"
|
||||
OPAM_GRAPH="opam-graph"
|
||||
MODULECTOMY="modulectomy"
|
||||
|
||||
for i in $(find "${DIR}" -type f -path \*output/bin\*); do
|
||||
LATEST_TREEMAPVIZ_VERSION="$($MODULECTOMY --version)"
|
||||
[ $? -ne 0 ] && die "Couldn't get modulectomy version"
|
||||
LATEST_DEPENDENCIESVIZ_VERSION="$($OPAM_GRAPH --version)"
|
||||
[ $? -ne 0 ] && die "Couldn't get opam-graph version"
|
||||
|
||||
TREEMAP_CACHE_DIR="${CACHE_DIR}/treemap_${LATEST_TREEMAPVIZ_VERSION}"
|
||||
DEPENDENCIES_CACHE_DIR="${CACHE_DIR}/dependencies_${LATEST_DEPENDENCIESVIZ_VERSION}"
|
||||
|
||||
if
|
||||
[ "${IGNORE_DONE}" = "false" ] && \
|
||||
[ -f "${TREEMAP_CACHE_DIR}/.done" ] && \
|
||||
[ -f "${DEPENDENCIES_CACHE_DIR}/.done" ]; then
|
||||
info "Nothing to do"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
ATTEMPTED_VIZS=0
|
||||
FAILED_VIZS=0
|
||||
|
||||
for i in $(find "${DATA_DIR}" -type f -path \*output/bin\*); do
|
||||
UUID=$(echo "${i}" | rev | cut -d '/' -f 4 | rev)
|
||||
ARGS="--cache-dir="${CACHE}" --uuid="${UUID}""
|
||||
FILE=$(basename "${i}")
|
||||
DIR=$(dirname "${i}")
|
||||
PDIR="${DIR}/.."
|
||||
ARGS2=
|
||||
if [ -f "${PDIR}/${FILE}.debug" ]; then
|
||||
ARGS2="${ARGS2} --debug-binary="${PDIR}/${FILE}.debug""
|
||||
fi
|
||||
if [ -f "${PDIR}/opam-switch" ]; then
|
||||
ARGS2="${ARGS2} --opam-switch="${PDIR}/opam-switch""
|
||||
fi
|
||||
if [ -z "${ARGS2}" ]; then
|
||||
echo "neither debug nor opam switch found for ${UUID}"
|
||||
else
|
||||
ARGS="${ARGS}${ARGS2} ${i}"
|
||||
./visualizations.sh ${ARGS}
|
||||
if ! "$VISUALIZATIONS_CMD" \
|
||||
--data-dir="${DATA_DIR}" \
|
||||
--cache-dir="${CACHE_DIR}" \
|
||||
--uuid="${UUID}"
|
||||
then
|
||||
FAILED_VIZS=$((FAILED_VIZS + 1))
|
||||
fi
|
||||
ATTEMPTED_VIZS=$((ATTEMPTED_VIZS + 1))
|
||||
done
|
||||
|
||||
if [ -n "$(ls -A "${TREEMAP_CACHE_DIR}")" ]; then
|
||||
touch "${TREEMAP_CACHE_DIR}/.done"
|
||||
|
||||
V=1
|
||||
while [ "$V" -lt "$LATEST_TREEMAPVIZ_VERSION" ]; do
|
||||
DIR_REMOVE="${CACHE_DIR}/treemap_${V}"
|
||||
if test -d "$DIR_REMOVE" && rm -r "$DIR_REMOVE"; then
|
||||
info "Removed old cache-directory: '$DIR_REMOVE'"
|
||||
fi
|
||||
V=$((V+1))
|
||||
done
|
||||
else
|
||||
warn "Treemap-viz cache-directory is still empty - problem?"
|
||||
fi
|
||||
|
||||
if [ -n "$(ls -A "${DEPENDENCIES_CACHE_DIR}")" ]; then
|
||||
touch "${DEPENDENCIES_CACHE_DIR}/.done"
|
||||
|
||||
V=1
|
||||
while [ "$V" -lt "$LATEST_DEPENDENCIESVIZ_VERSION" ]; do
|
||||
DIR_REMOVE="${CACHE_DIR}/dependencies_${V}"
|
||||
if test -d "$DIR_REMOVE" && rm -r "$DIR_REMOVE"; then
|
||||
info "Removed old cache-directory: '$DIR_REMOVE'"
|
||||
fi
|
||||
V=$((V+1))
|
||||
done
|
||||
else
|
||||
warn "Dependencies-viz cache-directory is still empty - problem?"
|
||||
fi
|
||||
|
||||
info "Batch creation of visualizations for $ATTEMPTED_VIZS binaries, finished with $FAILED_VIZS failures: $(date)"
|
||||
|
||||
|
|
|
|||
|
|
@ -23,7 +23,6 @@ mkdir -p "$bindir" "$debiandir" "$systemddir"
|
|||
install $bdir/builder-web $bindir/builder-web
|
||||
install $bdir/builder-migrations $bindir/builder-migrations
|
||||
install $bdir/builder-db $bindir/builder-db
|
||||
install $bdir/builder-viz $bindir/builder-viz
|
||||
|
||||
# service script
|
||||
install -m 0644 $basedir/packaging/debian/builder-web.service $systemddir/builder-web.service
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#!/bin/sh
|
||||
|
||||
set -ex
|
||||
set -e
|
||||
#set -x
|
||||
|
||||
prog_NAME=$(basename "${0}")
|
||||
|
||||
|
|
@ -9,6 +10,11 @@ warn()
|
|||
echo "${prog_NAME}: WARN: $*"
|
||||
}
|
||||
|
||||
info()
|
||||
{
|
||||
echo "${prog_NAME}: INFO: $*"
|
||||
}
|
||||
|
||||
err()
|
||||
{
|
||||
echo "${prog_NAME}: ERROR: $*" 1>&2
|
||||
|
|
@ -23,60 +29,106 @@ die()
|
|||
usage()
|
||||
{
|
||||
cat <<EOM 1>&2
|
||||
usage: ${prog_NAME} [ OPTIONS ] FILE
|
||||
usage: ${prog_NAME} [ OPTIONS ]
|
||||
Generates visualizations
|
||||
Options:
|
||||
--debug-binary=STRING
|
||||
Path to debug binary.
|
||||
--opam-switch=STRING
|
||||
Path to opam switch.
|
||||
--uuid=STRING
|
||||
UUID of build.
|
||||
--data-dir=STRING
|
||||
Path to the data directory.
|
||||
--cache-dir=STRING
|
||||
Path to the cache directory.
|
||||
EOM
|
||||
exit 1
|
||||
}
|
||||
|
||||
DEBUG=
|
||||
OPAM=
|
||||
UUID=
|
||||
CACHE=
|
||||
CACHE_DIR=
|
||||
DATA_DIR=
|
||||
|
||||
while [ $# -gt 1 ]; do
|
||||
while [ $# -gt 0 ]; do
|
||||
OPT="$1"
|
||||
|
||||
case "${OPT}" in
|
||||
--debug-binary=*)
|
||||
DEBUG="${OPT##*=}"
|
||||
;;
|
||||
--opam-switch=*)
|
||||
OPAM="${OPT##*=}"
|
||||
;;
|
||||
--uuid=*)
|
||||
UUID="${OPT##*=}"
|
||||
;;
|
||||
--cache-dir=*)
|
||||
CACHE="${OPT##*=}"
|
||||
CACHE_DIR="${OPT##*=}"
|
||||
;;
|
||||
--*)
|
||||
warn "Ignoring unknown option: '${OPT}'"
|
||||
--data-dir=*)
|
||||
DATA_DIR="${OPT##*=}"
|
||||
;;
|
||||
*)
|
||||
err "Unknown option: '${OPT}'"
|
||||
usage
|
||||
warn "Ignoring unknown option: '${OPT}' (Note that this script reads DB)"
|
||||
;;
|
||||
esac
|
||||
shift
|
||||
done
|
||||
|
||||
[ -z "${UUID}" ] && die "The --uuid option must be specified"
|
||||
[ -z "${CACHE}" ] && die "The --cache-dir option must be specified"
|
||||
[ -z "${OPAM}" ] && die "The --opam-switch option must be specified"
|
||||
[ -z "${CACHE_DIR}" ] && die "The --cache-dir option must be specified"
|
||||
[ -z "${DATA_DIR}" ] && die "The --data-dir option must be specified"
|
||||
|
||||
FILENAME="${1}"
|
||||
CACHE_DIR="${CACHE}/${UUID}"
|
||||
BUILDER_VIZ="builder-viz"
|
||||
info "processing UUID '$UUID'"
|
||||
|
||||
DB="${DATA_DIR}/builder.sqlite3"
|
||||
|
||||
get_main_binary () {
|
||||
sqlite3 "${DB}" <<EOF
|
||||
select ba.localpath from build as b
|
||||
join build_artifact as ba on ba.build = b.id and b.main_binary = ba.id
|
||||
where uuid = '$UUID';
|
||||
EOF
|
||||
}
|
||||
|
||||
BIN="${DATA_DIR}/$(get_main_binary)"
|
||||
[ -z "${BIN}" ] && die "No main-binary found in db '$DB' for build '$UUID'"
|
||||
|
||||
get_debug_binary () {
|
||||
sqlite3 "${DB}" <<EOF
|
||||
select ba.localpath from build as b
|
||||
join build_artifact as ba on ba.build = b.id
|
||||
where
|
||||
uuid = '$UUID'
|
||||
and ba.localpath like '%.debug';
|
||||
EOF
|
||||
}
|
||||
|
||||
DEBUG_BIN_RELATIVE="$(get_debug_binary)"
|
||||
|
||||
get_opam_switch () {
|
||||
sqlite3 "${DB}" <<EOF
|
||||
select ba.localpath from build as b
|
||||
join build_artifact as ba on ba.build = b.id
|
||||
where
|
||||
uuid = '$UUID'
|
||||
and ba.filepath = 'opam-switch';
|
||||
EOF
|
||||
}
|
||||
|
||||
OPAM_SWITCH="$(get_opam_switch)"
|
||||
[ -z "${OPAM_SWITCH}" ] && die "No 'opam-switch' found in db '$DB' for build '$UUID'"
|
||||
OPAM_SWITCH="${DATA_DIR}/${OPAM_SWITCH}"
|
||||
|
||||
#START debug print values
|
||||
# echo "UUID = $UUID"
|
||||
# echo "CACHE_DIR = $CACHE_DIR"
|
||||
# echo "DATA_DIR = $DATA_DIR"
|
||||
# echo "DB = $DB"
|
||||
# echo "BIN = $BIN"
|
||||
# echo "DEBUG_BIN = $DEBUG_BIN"
|
||||
# echo "OPAM_SWITCH = $OPAM_SWITCH"
|
||||
#END debug print values
|
||||
|
||||
OPAM_GRAPH="opam-graph"
|
||||
MODULECTOMY="modulectomy"
|
||||
|
||||
LATEST_TREEMAPVIZ_VERSION="$($MODULECTOMY --version)"
|
||||
LATEST_DEPENDENCIESVIZ_VERSION="$($OPAM_GRAPH --version)"
|
||||
|
||||
TREEMAP_CACHE_DIR="${CACHE_DIR}/treemap_${LATEST_TREEMAPVIZ_VERSION}"
|
||||
DEPENDENCIES_CACHE_DIR="${CACHE_DIR}/dependencies_${LATEST_DEPENDENCIESVIZ_VERSION}"
|
||||
|
||||
mktemp_aux () {
|
||||
if [ "$(uname)" = "Linux" ]; then
|
||||
|
|
@ -84,45 +136,96 @@ mktemp_aux () {
|
|||
elif [ "$(uname)" = "FreeBSD" ]; then
|
||||
mktemp -t "$1"
|
||||
else
|
||||
echo 'Unsupported platform'; exit 1
|
||||
die 'Unsupported platform'
|
||||
fi
|
||||
}
|
||||
TMPTREE=$(mktemp_aux treeviz)
|
||||
TMPOPAM=$(mktemp_aux opamviz)
|
||||
|
||||
TMPTREE=$(mktemp_aux viz_treemap)
|
||||
TMPDEPENDENCIES=$(mktemp_aux viz_dependencies)
|
||||
|
||||
cleanup () {
|
||||
rm -rf "${TMPTREE}" "${TMPOPAM}"
|
||||
rm -rf "${TMPTREE}" "${TMPDEPENDENCIES}"
|
||||
}
|
||||
|
||||
trap cleanup EXIT
|
||||
|
||||
if [ -e "${CACHE_DIR}.dependencies.html" ]; then
|
||||
echo "Dependency visualization already exists ${CACHE_DIR}.dependencies.html"
|
||||
# /// Dependencies viz
|
||||
|
||||
if [ ! -d "${DEPENDENCIES_CACHE_DIR}" ]; then
|
||||
mkdir "${DEPENDENCIES_CACHE_DIR}"
|
||||
fi
|
||||
|
||||
OPAM_SWITCH_FILEPATH='opam-switch'
|
||||
|
||||
get_opam_switch_hash () {
|
||||
sqlite3 "${DB}" <<EOF
|
||||
select lower(hex(ba.sha256)) from build as b
|
||||
join build_artifact as ba on ba.build = b.id
|
||||
where uuid = '$UUID'
|
||||
and ba.filepath = '$OPAM_SWITCH_FILEPATH';
|
||||
EOF
|
||||
}
|
||||
|
||||
DEPENDENCIES_INPUT_HASH="$(get_opam_switch_hash)"
|
||||
DEPENDENCIES_VIZ_FILENAME="${DEPENDENCIES_CACHE_DIR}/${DEPENDENCIES_INPUT_HASH}.html"
|
||||
|
||||
if [ -e "${DEPENDENCIES_VIZ_FILENAME}" ]; then
|
||||
info "Dependency visualization already exists: '${DEPENDENCIES_VIZ_FILENAME}'"
|
||||
else
|
||||
if ${BUILDER_VIZ} dependencies "${OPAM}" > "${TMPOPAM}"; then
|
||||
mv "${TMPOPAM}" "${CACHE_DIR}.dependencies.html"
|
||||
if ${OPAM_GRAPH} --output-format=html "${OPAM_SWITCH}" > "${TMPDEPENDENCIES}"; then
|
||||
mv "${TMPDEPENDENCIES}" "${DEPENDENCIES_VIZ_FILENAME}"
|
||||
else
|
||||
die "opam-graph failed to generate visualization"
|
||||
fi
|
||||
fi
|
||||
|
||||
# /// Treemap viz
|
||||
|
||||
stat_aux () {
|
||||
if [ "$(uname)" = "Linux" ]; then
|
||||
stat -c "%s" "$1"
|
||||
elif [ "$(uname)" = "FreeBSD" ]; then
|
||||
stat -f "%z" "$1"
|
||||
else
|
||||
echo 'Unsupported platform'; exit 1
|
||||
die 'Unsupported platform'
|
||||
fi
|
||||
}
|
||||
|
||||
SIZE="$(stat_aux ${FILENAME})"
|
||||
SIZE="$(stat_aux "$BIN")"
|
||||
|
||||
if [ ! -z "${DEBUG}" ]; then
|
||||
if [ -e "${CACHE_DIR}.treemap.html" ]; then
|
||||
echo "Treemap visualization already exists ${CACHE_DIR}.treemap.html"
|
||||
if [ ! -d "${TREEMAP_CACHE_DIR}" ]; then
|
||||
mkdir "${TREEMAP_CACHE_DIR}"
|
||||
fi
|
||||
|
||||
get_debug_bin_hash () {
|
||||
sqlite3 "${DB}" <<EOF
|
||||
select lower(hex(ba.sha256)) from build as b
|
||||
join build_artifact as ba on ba.build = b.id
|
||||
where uuid = '$UUID'
|
||||
and ba.filepath like '%.debug';
|
||||
EOF
|
||||
}
|
||||
|
||||
TREEMAP_INPUT_HASH="$(get_debug_bin_hash)"
|
||||
TREEMAP_VIZ_FILENAME="${TREEMAP_CACHE_DIR}/${TREEMAP_INPUT_HASH}.html"
|
||||
|
||||
if [ -n "${DEBUG_BIN_RELATIVE}" ]; then
|
||||
DEBUG_BIN="${DATA_DIR}/$(get_debug_binary)"
|
||||
if [ -e "${TREEMAP_VIZ_FILENAME}" ]; then
|
||||
info "Treemap visualization already exists: '${TREEMAP_VIZ_FILENAME}'"
|
||||
else
|
||||
if ${BUILDER_VIZ} treemap "${DEBUG}" "${SIZE}" > "${TMPTREE}"; then
|
||||
mv "${TMPTREE}" "${CACHE_DIR}.treemap.html"
|
||||
if
|
||||
${MODULECTOMY} \
|
||||
--robur-defaults \
|
||||
--with-scale="${SIZE}" \
|
||||
"${DEBUG_BIN}" \
|
||||
> "${TMPTREE}"
|
||||
then
|
||||
mv "${TMPTREE}" "${TREEMAP_VIZ_FILENAME}"
|
||||
else
|
||||
die "modulectomy failed to generate visualization"
|
||||
fi
|
||||
fi
|
||||
else
|
||||
echo "No --debug-binary provided, not producing any treemap"
|
||||
info "No --debug-binary provided, not producing any treemap"
|
||||
fi
|
||||
|
|
|
|||
Loading…
Reference in a new issue