robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'main' into redirect-job-and-build

Browse source
This commit is contained in:
rand00 2022-04-11 18:13:12 +02:00
commit 8f173295ab
4 changed files with 49 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
bin/builder_web_app.ml
View file

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

34
lib/builder_web.ml
View file

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

5
lib/model.ml
View file

@ -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
View file

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