diff --git a/bin/builder_system.ml b/bin/builder_system.ml index 0c3bd1c..3ac2767 100644 --- a/bin/builder_system.ml +++ b/bin/builder_system.ml @@ -11,6 +11,9 @@ let default_datadir = | `FreeBSD -> "/var/db/builder-web" | `Linux -> "/var/lib/builder-web" +let default_cachedir = + default_datadir ^ "/_cache" + let default_configdir = match Lazy.force uname with | `FreeBSD -> "/usr/local/etc/builder-web" diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index cb43880..fca18df 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.ml @@ -78,9 +78,10 @@ let init_influx name data = in Lwt.async report -let setup_app level influx port host datadir configdir = +let setup_app level influx port host datadir cachedir configdir = let dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in let datadir = Fpath.v datadir in + let cachedir = Fpath.v cachedir in let configdir = Fpath.v configdir in let () = init_influx "builder-web" influx in match Builder_web.init dbpath datadir with @@ -97,7 +98,7 @@ let setup_app level influx port host datadir configdir = @@ Dream.logger @@ Dream.sql_pool ("sqlite3:" ^ dbpath) @@ Http_status_metrics.handle - @@ Builder_web.add_routes datadir configdir + @@ Builder_web.add_routes ~datadir ~cachedir ~configdir @@ Builder_web.not_found open Cmdliner @@ -127,6 +128,10 @@ let datadir = let doc = "data directory" in Arg.(value & opt dir Builder_system.default_datadir & info [ "d"; "datadir" ] ~doc) +let cachedir = + let doc = "cache directory" in + Arg.(value & opt dir Builder_system.default_cachedir & info [ "cachedir" ] ~doc) + let configdir = let doc = "config directory" in Arg.(value & opt dir Builder_system.default_configdir & info [ "c"; "configdir" ] ~doc) @@ -144,7 +149,13 @@ let influx = Arg.(value & opt (some ip_port) None & info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]") let () = - let term = Term.(const setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir $ configdir) in + let term = Term.( + const setup_app + $ Logs_cli.level () + $ influx + $ port $ host + $ datadir $ cachedir $ configdir + ) in let info = Cmd.info "Builder web" ~doc:"Builder web" ~man:[] in Cmd.v info term |> Cmd.eval diff --git a/lib/builder_web.ml b/lib/builder_web.ml index edb929c..4785340 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -104,8 +104,9 @@ let dream_svg ?status ?code ?headers body = |> Dream.with_header "Content-Type" "image/svg+xml" |> Lwt.return -let add_routes datadir configdir = +let add_routes ~datadir ~cachedir ~configdir = let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in + let cachedir_global = Dream.new_global ~name:"cachedir" (fun () -> cachedir) in let builds req = Dream.sql req Model.jobs_with_section_synopsis @@ -194,12 +195,12 @@ let add_routes datadir configdir = |> Lwt_result.ok in - let try_load_cached_visualization ~datadir ~uuid typ = + let try_load_cached_visualization ~cachedir ~uuid typ = let fn = match typ with | `Treemap -> "treemap" | `Dependencies -> "dependencies" in - let path = Fpath.(datadir / "_cache" / Uuidm.to_string uuid + fn + "html") 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") @@ -214,9 +215,9 @@ let add_routes datadir configdir = let job_build_viz viz_typ req = let _job_name = Dream.param "job" req and build = Dream.param "build" req - and datadir = Dream.global datadir_global req in + and cachedir = Dream.global cachedir_global req in get_uuid build >>= fun uuid -> - (try_load_cached_visualization ~datadir ~uuid viz_typ + (try_load_cached_visualization ~cachedir ~uuid viz_typ |> if_error "Error getting cached visualization") >>= fun svg_html -> Lwt_result.ok (Dream.html svg_html) @@ -359,9 +360,10 @@ let add_routes datadir configdir = |> Lwt_result.ok | false -> let datadir = Dream.global datadir_global req in + let cachedir = Dream.global cachedir_global req in (Lwt.return (Dream.local Authorization.user_info_local req |> Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) -> - Dream.sql req (Model.add_build ~configdir ~datadir user_id exec)) + Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec)) |> if_error "Internal server error" ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e)) >>= fun () -> Dream.respond "" |> Lwt_result.ok @@ -452,6 +454,7 @@ let add_routes datadir configdir = |> Lwt_result.ok | false -> let datadir = Dream.global datadir_global req in + let cachedir = Dream.global cachedir_global req in let exec = let now = Ptime_clock.now () in ({ Builder.name = job ; platform ; script = "" }, uuid, [], now, now, Builder.Exited 0, @@ -459,7 +462,7 @@ let add_routes datadir configdir = in (Lwt.return (Dream.local Authorization.user_info_local req |> Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) -> - Dream.sql req (Model.add_build ~configdir ~datadir user_id exec)) + Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec)) |> if_error "Internal server error" ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e)) >>= fun () -> Dream.respond "" |> Lwt_result.ok diff --git a/lib/model.ml b/lib/model.ml index d86b8d1..22b6875 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -305,8 +305,9 @@ let prepare_staging staging_dir = else Lwt_result.return () let add_build - ~configdir ~datadir + ~cachedir + ~configdir user_id ((job : Builder.script_job), uuid, console, start, finish, result, raw_artifacts) (module Db : CONN) = @@ -445,7 +446,7 @@ let add_build (opt_str ~prefix:"opam-switch" opam_switch) @ [ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ; "--uuid=" ^ uuid ; "--platform=" ^ platform ; - "--cache-dir=" ^ fp_str (Fpath.v "_cache") ; + "--cache-dir=" ^ Fpath.to_string cachedir ; fp_str main_binary ])) in Log.debug (fun m -> m "executing hooks with %s" args); diff --git a/lib/model.mli b/lib/model.mli index 8e993e0..6982c61 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -95,8 +95,9 @@ val user : string -> Caqti_lwt.connection -> val authorized : [`user] Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Caqti_error.call_or_retrieve | `Msg of string ]) result Lwt.t val add_build : - configdir:Fpath.t -> datadir:Fpath.t -> + cachedir:Fpath.t -> + configdir:Fpath.t -> [`user] Builder_db.id -> (Builder.script_job * Uuidm.t * (int * string) list * Ptime.t * Ptime.t * Builder.execution_result * (Fpath.t * string) list) ->