Browse Source

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

pull/102/head
rand00 5 months ago
parent
commit
ab3be6ec8e
  1. 3
      bin/builder_system.ml
  2. 17
      bin/builder_web_app.ml
  3. 17
      lib/builder_web.ml
  4. 5
      lib/model.ml
  5. 3
      lib/model.mli

3
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"

17
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

17
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

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

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

Loading…
Cancel
Save