builder-web: Added --cachedir CLI arg for staging new vizs

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"

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

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

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

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