Merge pull request 'builder-web: Added --cachedir CLI param for staging new vizs' (#102) from 20220329_passing_separate_cache-dir into main

Reviewed-on: https://git.robur.io/robur/builder-web/pulls/102

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 = Option.fold ~none:Fpath.(datadir / "_cache") ~some:Fpath.v 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,14 @@ 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 (some ~none:"DATADIR/_cache" dir) None
+    & info [ "cachedir" ] ~doc
+  )
+
 let configdir =
   let doc = "config directory" in
   Arg.(value & opt dir Builder_system.default_configdir & info [ "c"; "configdir" ] ~doc)
@@ -144,7 +153,10 @@ 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")
@@ -211,23 +212,12 @@ let add_routes datadir configdir =
       ) |> Lwt_result.map_err (fun exn -> `Msg (Printexc.to_string exn))
   in
 
-  let job_build_viztreemap req =
+  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 `Treemap
-     |> if_error "Error getting cached visualization")
-    >>= fun svg_html ->
-    Lwt_result.ok (Dream.html svg_html)
-  in
-
-  let job_build_vizdependencies req =
-    let _job_name = Dream.param "job" req
-    and build = Dream.param "build" req
-    and datadir = Dream.global datadir_global req in
-    get_uuid build >>= fun uuid ->
-    (try_load_cached_visualization ~datadir ~uuid `Dependencies
+    (try_load_cached_visualization ~cachedir ~uuid viz_typ
      |> if_error "Error getting cached visualization")
     >>= fun svg_html ->
     Lwt_result.ok (Dream.html svg_html)
@@ -370,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
@@ -463,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,
@@ -470,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
@@ -486,8 +478,8 @@ let add_routes datadir configdir =
     Dream.get "/job/:job/build/:build/" (w job_build);
     Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
     Dream.get "/job/:job/build/:build/main-binary" (w redirect_main_binary);
-    Dream.get "/job/:job/build/:build/viztreemap" (w job_build_viztreemap);
-    Dream.get "/job/:job/build/:build/vizdependencies" (w job_build_vizdependencies);
+    Dream.get "/job/:job/build/:build/viztreemap" (w @@ job_build_viz `Treemap);
+    Dream.get "/job/:job/build/:build/vizdependencies" (w @@ job_build_viz `Dependencies);
     Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script));
     Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console));
     Dream.get "/failed-builds/" (w failed_builds);

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