add builder-db verify-cache-dir command (#113)
Co-authored-by: rand00 <oth.rand@gmail.com> Co-authored-by: Reynir Björnsson <reynir@reynir.dk> Reviewed-on: https://git.robur.io/robur/builder-web/pulls/113 Co-authored-by: rand <rand@r7p5.earth> Co-committed-by: rand <rand@r7p5.earth>
This commit is contained in:
rand
parent
09a180c3cd
commit
5307a7b91a
3 changed files with 482 additions and 121 deletions
|
|
@ -306,6 +306,318 @@ let verify_data_dir () datadir =
|
|||
files_untracked;
|
||||
or_die 1 r
|
||||
|
||||
module Verify_cache_dir = struct
|
||||
|
||||
let verify_dir_exists d =
|
||||
let* dir_exists = Bos.OS.Dir.exists d in
|
||||
if dir_exists then Ok () else
|
||||
Error (`Msg (Fmt.str "The directory '%a' doesn't exist"
|
||||
Fpath.pp d))
|
||||
|
||||
let viz_types = [
|
||||
`Treemap;
|
||||
`Dependencies;
|
||||
]
|
||||
|
||||
let string_is_int s = match int_of_string_opt s with
|
||||
| None -> false
|
||||
| Some _ -> true
|
||||
|
||||
let verify_cache_subdir ~cachedir d =
|
||||
match Bos.OS.Dir.exists Fpath.(cachedir // d) with
|
||||
| Ok false -> ()
|
||||
| Error _ ->
|
||||
Logs.warn (fun m ->
|
||||
m "Couldn't read file in cache: '%a'" Fpath.pp d)
|
||||
| Ok true ->
|
||||
let dir_str = Fpath.to_string d in
|
||||
let is_valid =
|
||||
viz_types |> List.exists (fun viz_type ->
|
||||
let viz_prefix = Builder_web.Viz_aux.viz_type_to_string viz_type in
|
||||
let prefix = viz_prefix ^ "_" in
|
||||
let has_prefix = String.starts_with ~prefix dir_str in
|
||||
let has_valid_ending =
|
||||
if not has_prefix then false else
|
||||
let ending =
|
||||
String.(sub dir_str
|
||||
(length prefix)
|
||||
(length dir_str - length prefix))
|
||||
in
|
||||
string_is_int ending
|
||||
in
|
||||
has_prefix && has_valid_ending
|
||||
)
|
||||
in
|
||||
if not is_valid then
|
||||
Logs.warn (fun m ->
|
||||
m "Invalid cache subdirectory name: '%s'" dir_str)
|
||||
|
||||
let get_latest_viz_version viz_typ =
|
||||
let* v_str, run_status = begin match viz_typ with
|
||||
| `Treemap ->
|
||||
let cmd = Bos.Cmd.(v "modulectomy" % "--version") in
|
||||
Bos.OS.Cmd.(cmd |> run_out |> out_string)
|
||||
| `Dependencies ->
|
||||
let cmd = Bos.Cmd.(v "opam-graph" % "--version") in
|
||||
Bos.OS.Cmd.(cmd |> run_out |> out_string)
|
||||
end in
|
||||
match run_status with
|
||||
| (cmd_info, `Exited 0) ->
|
||||
begin try Ok (int_of_string v_str) with Failure _ ->
|
||||
let msg =
|
||||
Fmt.str "Couldn't parse latest version from %a: '%s'"
|
||||
Bos.Cmd.pp (Bos.OS.Cmd.run_info_cmd cmd_info)
|
||||
v_str
|
||||
in
|
||||
Error (`Msg msg)
|
||||
end
|
||||
| (cmd_info, _) ->
|
||||
let msg =
|
||||
Fmt.str "Error running visualization cmd: '%a'"
|
||||
Bos.Cmd.pp (Bos.OS.Cmd.run_info_cmd cmd_info)
|
||||
in
|
||||
Error (`Msg msg)
|
||||
|
||||
let verify_cachedir_contents cachedir =
|
||||
let* contents = Bos.OS.Dir.contents ~dotfiles:false ~rel:true cachedir in
|
||||
let contents =
|
||||
List.filter (fun f ->
|
||||
match Bos.OS.Dir.exists Fpath.(cachedir // f) with
|
||||
| Ok true -> true
|
||||
| Ok false ->
|
||||
Logs.warn (fun m -> m "Non-directory file '%a', ignoring" Fpath.pp f); false
|
||||
| Error `Msg err ->
|
||||
Logs.warn (fun m -> m "%s" err);
|
||||
false)
|
||||
contents
|
||||
in
|
||||
let () = contents |> List.iter (verify_cache_subdir ~cachedir) in
|
||||
let+ latest_versioned_subdirs =
|
||||
viz_types |> List.fold_left (fun acc viz_type ->
|
||||
let viz_prefix = Builder_web.Viz_aux.viz_type_to_string viz_type in
|
||||
let* acc = acc in
|
||||
let+ latest_viz_version = get_latest_viz_version viz_type in
|
||||
let path = Fpath.(
|
||||
cachedir / Fmt.str "%s_%d" viz_prefix latest_viz_version
|
||||
) in
|
||||
(viz_prefix, path) :: acc
|
||||
) (Ok [])
|
||||
in
|
||||
latest_versioned_subdirs |>
|
||||
List.iter (fun (viz_name, dir) ->
|
||||
match verify_dir_exists dir with
|
||||
| Error _ ->
|
||||
Logs.warn (fun m ->
|
||||
m "Latest versioned cache directory for %s doesn't exist: '%a'"
|
||||
viz_name Fpath.pp dir)
|
||||
| Ok () ->
|
||||
let done_file = Fpath.(dir / ".done") in
|
||||
match Bos.OS.File.exists done_file with
|
||||
| Ok true -> ()
|
||||
| Ok false ->
|
||||
Logs.warn (fun m ->
|
||||
m "'%a' doesn't exist (is batch-viz.sh running now?)"
|
||||
Fpath.pp Fpath.(dir // done_file))
|
||||
| Error `Msg err ->
|
||||
Logs.warn (fun m -> m "%s" err))
|
||||
|
||||
module Build = struct
|
||||
|
||||
type t = {
|
||||
uuid : Uuidm.t;
|
||||
job_name : string;
|
||||
hash_opam_switch : Cstruct.t option;
|
||||
hash_debug_bin : Cstruct.t option;
|
||||
}
|
||||
|
||||
let repr =
|
||||
let encode { uuid; job_name; hash_opam_switch; hash_debug_bin } =
|
||||
Ok (uuid, job_name, hash_opam_switch, hash_debug_bin) in
|
||||
let decode (uuid, job_name, hash_opam_switch, hash_debug_bin) =
|
||||
Ok { uuid; job_name; hash_opam_switch; hash_debug_bin }
|
||||
in
|
||||
Caqti_type.custom ~encode ~decode
|
||||
Caqti_type.(
|
||||
tup4
|
||||
Builder_db.Rep.uuid
|
||||
string
|
||||
(option Builder_db.Rep.cstruct)
|
||||
(option Builder_db.Rep.cstruct))
|
||||
|
||||
end
|
||||
|
||||
let builds_vizdeps_q =
|
||||
Caqti_type.unit ->* Build.repr @@ {|
|
||||
SELECT
|
||||
b.uuid,
|
||||
(SELECT name FROM job WHERE id = b.job) AS job_name,
|
||||
ba_opam_switch.sha256 hash_opam_switch,
|
||||
ba_debug_bin.sha256 hash_debug_bin
|
||||
FROM build AS b
|
||||
LEFT JOIN build_artifact AS ba_opam_switch ON
|
||||
ba_opam_switch.build = b.id
|
||||
AND ba_opam_switch.filepath = 'opam-switch'
|
||||
LEFT JOIN build_artifact AS ba_debug_bin ON
|
||||
ba_debug_bin.build = b.id
|
||||
AND ba_debug_bin.localpath LIKE '%.debug'
|
||||
|}
|
||||
|
||||
let check_viz_nonempty ~cachedir ~viz_typ ~hash =
|
||||
let module Viz_aux = Builder_web.Viz_aux in
|
||||
let* latest_version =
|
||||
Viz_aux.get_viz_version_from_dirs ~cachedir ~viz_typ
|
||||
in
|
||||
let `Hex viz_input_hash = Hex.of_cstruct hash in
|
||||
let* viz_path =
|
||||
Viz_aux.choose_versioned_viz_path
|
||||
~cachedir
|
||||
~viz_typ
|
||||
~viz_input_hash
|
||||
~current_version:latest_version
|
||||
in
|
||||
let* path_info = Bos.OS.Path.stat viz_path in
|
||||
if path_info.Unix.st_size > 0 then Ok () else
|
||||
let msg = Fmt.str "Empty file: '%a'" Fpath.pp viz_path in
|
||||
Error (`Msg msg)
|
||||
|
||||
let verify_viz_file_vizdeps ~cachedir build =
|
||||
match build.Build.hash_opam_switch with
|
||||
| None ->
|
||||
Logs.warn (fun m ->
|
||||
m "%s: uuid '%a': Doesn't support dependencies viz because of \
|
||||
missing 'opam-switch'"
|
||||
build.job_name
|
||||
Uuidm.pp build.uuid)
|
||||
| Some hash_opam_switch ->
|
||||
match
|
||||
check_viz_nonempty
|
||||
~cachedir
|
||||
~viz_typ:`Dependencies
|
||||
~hash:hash_opam_switch
|
||||
with
|
||||
| Ok () -> ()
|
||||
| Error (`Msg err) ->
|
||||
Logs.warn (fun m ->
|
||||
m "%s: uuid '%a': %s"
|
||||
build.job_name
|
||||
Uuidm.pp build.uuid
|
||||
err)
|
||||
|
||||
let verify_viz_file_viztreemap ~cachedir build =
|
||||
match build.Build.hash_debug_bin with
|
||||
| None -> ()
|
||||
| Some hash_debug_bin ->
|
||||
match
|
||||
check_viz_nonempty
|
||||
~cachedir
|
||||
~viz_typ:`Treemap
|
||||
~hash:hash_debug_bin
|
||||
with
|
||||
| Ok () -> ()
|
||||
| Error (`Msg err) ->
|
||||
Logs.warn (fun m ->
|
||||
m "%s: uuid '%a': %s"
|
||||
build.job_name
|
||||
Uuidm.pp build.uuid
|
||||
err)
|
||||
|
||||
let verify_viz_files ~cachedir build =
|
||||
let () = verify_viz_file_vizdeps ~cachedir build in
|
||||
let () = verify_viz_file_viztreemap ~cachedir build in
|
||||
()
|
||||
|
||||
let has_completed ~cachedir ~viz_typ ~version =
|
||||
let module Viz_aux = Builder_web.Viz_aux in
|
||||
let viz_dir = Viz_aux.viz_dir
|
||||
~cachedir
|
||||
~viz_typ
|
||||
~version
|
||||
in
|
||||
let* viz_dir_exists = Bos.OS.Dir.exists viz_dir in
|
||||
let* done_file_exists = Bos.OS.File.exists Fpath.(viz_dir / ".done") in
|
||||
Ok (viz_dir_exists && done_file_exists)
|
||||
|
||||
let extract_hash ~viz_typ { Build.hash_debug_bin; hash_opam_switch; _ } =
|
||||
match viz_typ with
|
||||
| `Treemap -> hash_debug_bin
|
||||
| `Dependencies -> hash_opam_switch
|
||||
|
||||
let verify_completeness ~cachedir ~viz_typ ~version build =
|
||||
let module Viz_aux = Builder_web.Viz_aux in
|
||||
match extract_hash ~viz_typ build with
|
||||
| None -> ()
|
||||
| Some input_hash ->
|
||||
let `Hex input_hash = Hex.of_cstruct input_hash in
|
||||
let viz_path = Viz_aux.viz_path
|
||||
~cachedir
|
||||
~viz_typ
|
||||
~version
|
||||
~input_hash
|
||||
in
|
||||
match Bos.OS.File.exists viz_path with
|
||||
| Ok true -> ()
|
||||
| Error (`Msg err) ->
|
||||
Logs.warn (fun m -> m "verify_completeness: Failure: %s" err)
|
||||
| Ok false ->
|
||||
Logs.warn (fun m ->
|
||||
m "%s: uuid '%a': Cache for visualization is marked as done, \
|
||||
but file '%a' is missing"
|
||||
build.Build.job_name
|
||||
Uuidm.pp build.Build.uuid
|
||||
Fpath.pp viz_path)
|
||||
|
||||
type msg = [ `Msg of string ]
|
||||
|
||||
let open_error_msg : ('a, msg) result -> ('a, [> msg]) result =
|
||||
function
|
||||
| Ok _ as v -> v
|
||||
| Error e -> Error (e : msg :> [> msg])
|
||||
|
||||
let verify () datadir cachedir =
|
||||
let module Viz_aux = Builder_web.Viz_aux in
|
||||
begin
|
||||
let* datadir = Fpath.of_string datadir |> open_error_msg in
|
||||
let* cachedir = match cachedir with
|
||||
| Some d -> Fpath.of_string d |> open_error_msg
|
||||
| None -> Ok Fpath.(datadir / "_cache")
|
||||
in
|
||||
let* () = verify_dir_exists cachedir in
|
||||
let* () = verify_cachedir_contents cachedir in
|
||||
let* (module Db : Caqti_blocking.CONNECTION) =
|
||||
let path = Fpath.(datadir / "builder.sqlite3" |> to_string) in
|
||||
let query = ["create", ["false"]] in
|
||||
connect (Uri.make ~scheme:"sqlite3" ~path ~query ())
|
||||
in
|
||||
let* viz_types_to_check =
|
||||
viz_types
|
||||
|> List.fold_left (fun acc viz_typ ->
|
||||
let* acc = acc in
|
||||
let* latest_version =
|
||||
Viz_aux.get_viz_version_from_dirs ~cachedir ~viz_typ
|
||||
in
|
||||
let* has_completed = has_completed ~cachedir
|
||||
~viz_typ ~version:latest_version
|
||||
in
|
||||
if has_completed then
|
||||
Ok ((viz_typ, latest_version) :: acc)
|
||||
else
|
||||
Ok acc)
|
||||
(Ok [])
|
||||
in
|
||||
let+ () = Db.iter_s builds_vizdeps_q (fun build ->
|
||||
verify_viz_files ~cachedir build;
|
||||
List.iter (fun (viz_typ, version) ->
|
||||
verify_completeness ~cachedir ~viz_typ ~version build)
|
||||
viz_types_to_check;
|
||||
Ok ()
|
||||
) ()
|
||||
in
|
||||
()
|
||||
end
|
||||
|> or_die 1
|
||||
|
||||
end
|
||||
|
||||
module Asn = struct
|
||||
let decode_strict codec cs =
|
||||
match Asn.decode codec cs with
|
||||
|
|
@ -406,6 +718,12 @@ let datadir =
|
|||
opt dir Builder_system.default_datadir &
|
||||
info ~doc ["datadir"; "d"])
|
||||
|
||||
let cachedir =
|
||||
let doc = "cache directory" in
|
||||
Cmdliner.Arg.(value &
|
||||
opt (some dir) None &
|
||||
info ~doc ["cachedir"])
|
||||
|
||||
let jobname =
|
||||
let doc = "jobname" in
|
||||
Cmdliner.Arg.(required &
|
||||
|
|
@ -552,6 +870,12 @@ let verify_data_dir_cmd =
|
|||
let info = Cmd.info ~doc "verify-data-dir" in
|
||||
Cmd.v info term
|
||||
|
||||
let verify_cache_dir_cmd =
|
||||
let doc = "verify the cache directory" in
|
||||
let term = Term.(const Verify_cache_dir.verify $ setup_log $ datadir $ cachedir) in
|
||||
let info = Cmd.info ~doc "verify-cache-dir" in
|
||||
Cmd.v info term
|
||||
|
||||
let help_cmd =
|
||||
let topic =
|
||||
let doc = "Command to get help on" in
|
||||
|
|
@ -575,7 +899,9 @@ let () =
|
|||
user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd;
|
||||
user_disable_cmd;
|
||||
access_add_cmd; access_remove_cmd; job_remove_cmd;
|
||||
verify_input_id_cmd; verify_data_dir_cmd;
|
||||
verify_input_id_cmd;
|
||||
verify_data_dir_cmd;
|
||||
verify_cache_dir_cmd;
|
||||
extract_full_cmd ]
|
||||
|> Cmdliner.Cmd.eval
|
||||
|> exit
|
||||
|
|
|
|||
2
bin/dune
2
bin/dune
|
|
@ -13,4 +13,4 @@
|
|||
(public_name builder-db)
|
||||
(name builder_db_app)
|
||||
(modules builder_db_app)
|
||||
(libraries builder_db builder_system caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix builder))
|
||||
(libraries builder_web builder_db builder_system caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix builder))
|
||||
|
|
|
|||
|
|
@ -93,6 +93,159 @@ let get_uuid s =
|
|||
| None -> Error ("Bad uuid", `Bad_Request)
|
||||
else Error ("Bad uuid", `Bad_Request))
|
||||
|
||||
|
||||
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))
|
||||
>>= fun (_id, build) ->
|
||||
match build.Builder_db.Build.main_binary with
|
||||
| None -> Lwt_result.fail ("Resource not found", `Not_Found)
|
||||
| Some main_binary ->
|
||||
Model.build_artifact_by_id main_binary db
|
||||
|> if_error "Error getting main binary"
|
||||
|
||||
module Viz_aux = struct
|
||||
|
||||
let viz_type_to_string = function
|
||||
| `Treemap -> "treemap"
|
||||
| `Dependencies -> "dependencies"
|
||||
|
||||
let viz_dir ~cachedir ~viz_typ ~version =
|
||||
let typ_str = viz_type_to_string viz_typ in
|
||||
Fpath.(cachedir / Fmt.str "%s_%d" typ_str version)
|
||||
|
||||
let viz_path ~cachedir ~viz_typ ~version ~input_hash =
|
||||
Fpath.(
|
||||
viz_dir ~cachedir ~viz_typ ~version
|
||||
/ input_hash + "html"
|
||||
)
|
||||
|
||||
let choose_versioned_viz_path
|
||||
~cachedir
|
||||
~viz_typ
|
||||
~viz_input_hash
|
||||
~current_version =
|
||||
let ( >>= ) = Result.bind in
|
||||
let rec aux current_version =
|
||||
let path =
|
||||
viz_path ~cachedir
|
||||
~viz_typ
|
||||
~version:current_version
|
||||
~input_hash:viz_input_hash in
|
||||
Bos.OS.File.exists path >>= fun path_exists ->
|
||||
if path_exists then Ok path else (
|
||||
if current_version = 1 then
|
||||
Error (`Msg (Fmt.str "viz '%s': There exist no version of the requested \
|
||||
visualization"
|
||||
(viz_type_to_string viz_typ)))
|
||||
else
|
||||
aux @@ pred current_version
|
||||
)
|
||||
in
|
||||
aux current_version
|
||||
|
||||
let get_viz_version_from_dirs ~cachedir ~viz_typ =
|
||||
let ( >>= ) = Result.bind in
|
||||
Bos.OS.Dir.contents cachedir >>= fun versioned_dirs ->
|
||||
let max_cached_version =
|
||||
let viz_typ_str = viz_type_to_string viz_typ ^ "_" in
|
||||
versioned_dirs
|
||||
|> List.filter_map (fun versioned_dir ->
|
||||
match Bos.OS.Dir.exists versioned_dir with
|
||||
| Error (`Msg err) ->
|
||||
Logs.warn (fun m -> m "%s" err);
|
||||
None
|
||||
| Ok false -> None
|
||||
| Ok true ->
|
||||
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
|
||||
Result.error @@
|
||||
`Msg (Fmt.str "Couldn't find any visualization-version of %s"
|
||||
(viz_type_to_string viz_typ))
|
||||
else
|
||||
Result.ok max_cached_version
|
||||
|
||||
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
|
||||
|
||||
let try_load_cached_visualization ~cachedir ~uuid viz_typ db =
|
||||
Lwt.return (get_viz_version_from_dirs ~cachedir ~viz_typ)
|
||||
|> if_error "Error getting visualization version" >>= fun latest_viz_version ->
|
||||
hash_viz_input ~uuid viz_typ db >>= fun viz_input_hash ->
|
||||
(choose_versioned_viz_path
|
||||
~cachedir
|
||||
~current_version:latest_viz_version
|
||||
~viz_typ
|
||||
~viz_input_hash
|
||||
|> Lwt.return
|
||||
|> 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"
|
||||
|
||||
end
|
||||
|
||||
|
||||
let routes ~datadir ~cachedir ~configdir =
|
||||
let builds req =
|
||||
Dream.sql req Model.jobs_with_section_synopsis
|
||||
|
|
@ -163,18 +316,6 @@ let routes ~datadir ~cachedir ~configdir =
|
|||
|> Lwt_result.ok
|
||||
in
|
||||
|
||||
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))
|
||||
>>= fun (_id, build) ->
|
||||
match build.Builder_db.Build.main_binary with
|
||||
| None -> Lwt_result.fail ("Resource not found", `Not_Found)
|
||||
| Some main_binary ->
|
||||
Model.build_artifact_by_id main_binary db
|
||||
|> if_error "Error getting main binary"
|
||||
in
|
||||
|
||||
let redirect_main_binary req =
|
||||
let job_name = Dream.param req "job"
|
||||
and build = Dream.param req "build" in
|
||||
|
|
@ -186,117 +327,11 @@ let routes ~datadir ~cachedir ~configdir =
|
|||
|> 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
|
||||
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 ->
|
||||
Dream.sql req (try_load_cached_visualization ~cachedir ~uuid viz_typ)
|
||||
Dream.sql req (Viz_aux.try_load_cached_visualization ~cachedir ~uuid viz_typ)
|
||||
>>= fun svg_html ->
|
||||
Lwt_result.ok (Dream.html svg_html)
|
||||
in
|
||||
|
|
|
|||
Loading…
Reference in a new issue