diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index cb43880..7d20e03 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.ml @@ -78,26 +78,41 @@ 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 = + 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 | Error (#Caqti_error.load as e) -> Format.eprintf "Error: %a\n%!" Caqti_error.pp e; exit 2 - | Error (#Caqti_error.connect | #Caqti_error.call_or_retrieve | `Msg _ | `Wrong_version _ as e) -> + | Error ( + #Caqti_error.connect + | #Caqti_error.call_or_retrieve + | `Msg _ + | `Wrong_version _ as e + ) -> Format.eprintf "Error: %a\n%!" Builder_web.pp_error e; exit 1 | Ok () -> - let level = match level with None -> None | Some Logs.Debug -> Some `Debug | Some Info -> Some `Info | Some Warning -> Some `Warning | Some Error -> Some `Error | Some App -> None in + let level = match level with + | None -> None + | Some Logs.Debug -> Some `Debug + | Some Info -> Some `Info + | Some Warning -> Some `Warning + | Some Error -> Some `Error + | Some App -> None + in Dream.initialize_log ?level (); Dream.run ~port ~interface:host ~https:false @@ 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 +142,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 +167,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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 258d12c..cb07e61 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") @@ -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 @@ -503,8 +495,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); 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) ->