From 5307a7b91a99e0f72ce368879a55d0beb334d162 Mon Sep 17 00:00:00 2001 From: rand Date: Thu, 16 Jun 2022 09:03:05 +0000 Subject: [PATCH] add `builder-db verify-cache-dir` command (#113) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: rand00 Co-authored-by: Reynir Björnsson Reviewed-on: https://git.robur.io/robur/builder-web/pulls/113 Co-authored-by: rand Co-committed-by: rand --- bin/builder_db_app.ml | 328 +++++++++++++++++++++++++++++++++++++++++- bin/dune | 2 +- lib/builder_web.ml | 273 ++++++++++++++++++++--------------- 3 files changed, 482 insertions(+), 121 deletions(-) diff --git a/bin/builder_db_app.ml b/bin/builder_db_app.ml index 684ee43..2eb6c9c 100644 --- a/bin/builder_db_app.ml +++ b/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 diff --git a/bin/dune b/bin/dune index 5e7be34..98e4094 100644 --- a/bin/dune +++ b/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)) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 36233ef..8f6ef06 100644 --- a/lib/builder_web.ml +++ b/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