Browse Source

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>
pull/121/head
rand 2 months ago
committed by Reynir Björnsson
parent
commit
5307a7b91a
  1. 328
      bin/builder_db_app.ml
  2. 2
      bin/dune
  3. 273
      lib/builder_web.ml

328
bin/builder_db_app.ml

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

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

273
lib/builder_web.ml

@ -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…
Cancel
Save