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

Update to dream.1.0.0~alpha4

Browse source 
- Dream.path is deprecated. For now the deprecation is suppressed.

- Remove unused dream_svg.

- Remove datadir global. The datadir variable is in scope already, and
  global variables were removed in alpha3.

- Dream_tar.tar_response: flush before closing. It's unclear if this is
  necessary.

- Change Builder_web.add_routes to Builder_web.routes returning a list
  of routes, and in Builder_web_app construct the router.

- Builder_web.not_found is removed due to changes in Dream.router. It
  seems an error handler might be the way forward.
This commit is contained in:
Reynir Björnsson 2022-04-05 13:46:36 +01:00
parent 6e75a653bc
commit 3de78b1113
4 changed files with 58 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
bin/builder_web_app.ml
View file

@ -108,13 +108,12 @@ let setup_app level influx port host datadir cachedir configdir =
| Some App -> None | Some App -> None
in in
Dream.initialize_log ?level (); Dream.initialize_log ?level ();
Dream.run ~port ~interface:host ~https:false Dream.run ~port ~interface:host ~tls:false
@@ Dream.logger @@ Dream.logger
@@ Dream.sql_pool ("sqlite3:" ^ dbpath) @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
@@ Http_status_metrics.handle @@ Http_status_metrics.handle
@@ Builder_web.Middleware.remove_trailing_url_slash @@ Builder_web.Middleware.remove_trailing_url_slash
@@ Builder_web.add_routes ~datadir ~cachedir ~configdir @@ Dream.router (Builder_web.routes ~datadir ~cachedir ~configdir)
@@ Builder_web.not_found
open Cmdliner open Cmdliner

8
lib/authorization.ml
View file

@ -6,14 +6,14 @@ open Lwt.Syntax
let realm = "builder-web" let realm = "builder-web"
let user_info_local = Dream.new_local ~name:"user_info" () let user_info_field = Dream.new_field ~name:"user_info" ()
let authenticate handler = fun req -> let authenticate handler = fun req ->
let unauthorized () = let unauthorized () =
let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
Dream.respond ~headers ~status:`Unauthorized "Forbidden!" Dream.respond ~headers ~status:`Unauthorized "Forbidden!"
in in
match Dream.header "Authorization" req with match Dream.header req "Authorization" with
| None -> unauthorized () | None -> unauthorized ()
| Some data -> match String.split_on_char ' ' data with | Some data -> match String.split_on_char ' ' data with
| [ "Basic" ; user_pass ] -> | [ "Basic" ; user_pass ] ->
@ -31,7 +31,7 @@ let authenticate handler = fun req ->
match user_info with match user_info with
| Ok (Some (id, user_info)) -> | Ok (Some (id, user_info)) ->
if Builder_web_auth.verify_password pass user_info if Builder_web_auth.verify_password pass user_info
then handler (Dream.with_local user_info_local (id, user_info) req) then (Dream.set_field req user_info_field (id, user_info); handler req)
else unauthorized () else unauthorized ()
| Ok None -> | Ok None ->
let _ : _ Builder_web_auth.user_info = let _ : _ Builder_web_auth.user_info =
@ -45,7 +45,7 @@ let authenticate handler = fun req ->
Dream.respond ~status:`Bad_Request "Couldn't decode authorization" Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
let authorized req job_name = let authorized req job_name =
match Dream.local user_info_local req with match Dream.field req user_info_field with
| None -> Lwt.return (Error (`Msg "not authenticated")) | None -> Lwt.return (Error (`Msg "not authenticated"))
| Some (id, user) -> | Some (id, user) ->
if user.restricted then if user.restricted then

99
lib/builder_web.ml
View file

@ -60,12 +60,6 @@ let mime_lookup path =
let string_of_html = let string_of_html =
Format.asprintf "%a" (Tyxml.Html.pp ()) Format.asprintf "%a" (Tyxml.Html.pp ())
let not_found req =
let path = "/" ^ String.concat "/" (Dream.path req) in
let referer = Dream.header "referer" req in
Views.page_not_found ~path ~referer
|> string_of_html |> Dream.html ~status:`Not_Found
let or_error_response r = let or_error_response r =
let* r = r in let* r = r in
match r with match r with
@ -99,15 +93,7 @@ let get_uuid s =
| None -> Error ("Bad uuid", `Bad_Request) | None -> Error ("Bad uuid", `Bad_Request)
else Error ("Bad uuid", `Bad_Request)) else Error ("Bad uuid", `Bad_Request))
let dream_svg ?status ?code ?headers body = let routes ~datadir ~cachedir ~configdir =
Dream.response ?status ?code ?headers body
|> Dream.with_header "Content-Type" "image/svg+xml"
|> Lwt.return
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 = let builds req =
Dream.sql req Model.jobs_with_section_synopsis Dream.sql req Model.jobs_with_section_synopsis
|> if_error "Error getting jobs" |> if_error "Error getting jobs"
@ -138,8 +124,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let job req = let job req =
let job_name = Dream.param "job" req in let job_name = Dream.param req "job" in
let platform = Dream.query "platform" req in let platform = Dream.query req "platform" in
(Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) -> (Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
Dream.sql req (Model.builds_grouped_by_output job_id platform) >|= fun builds -> Dream.sql req (Model.builds_grouped_by_output job_id platform) >|= fun builds ->
(readme, builds)) (readme, builds))
@ -151,8 +137,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let job_with_failed req = let job_with_failed req =
let job_name = Dream.param "job" req in let job_name = Dream.param req "job" in
let platform = Dream.query "platform" req in let platform = Dream.query req "platform" in
(Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) -> (Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
Dream.sql req (Model.builds_grouped_by_output_with_failed job_id platform) >|= fun builds -> Dream.sql req (Model.builds_grouped_by_output_with_failed job_id platform) >|= fun builds ->
(readme, builds)) (readme, builds))
@ -164,9 +150,10 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let redirect_latest req = let redirect_latest req =
let job_name = Dream.param "job" req in let job_name = Dream.param req "job" in
let platform = Dream.query "platform" req in let platform = Dream.query req "platform" in
let path = Dream.path req |> String.concat "/" in (* FIXME *)
let path = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in
(Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= fun job_id -> (Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= fun job_id ->
Dream.sql req (Model.latest_successful_build_uuid job_id platform)) Dream.sql req (Model.latest_successful_build_uuid job_id platform))
>>= Model.not_found >>= Model.not_found
@ -177,8 +164,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let redirect_main_binary req = let redirect_main_binary req =
let job_name = Dream.param "job" req let job_name = Dream.param req "job"
and build = Dream.param "build" req in and build = Dream.param req "build" in
get_uuid build >>= fun uuid -> get_uuid build >>= fun uuid ->
Dream.sql req (Model.build uuid) Dream.sql req (Model.build uuid)
|> if_error "Error getting job build" |> if_error "Error getting job build"
@ -213,20 +200,18 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let job_build_viz viz_typ req = let job_build_viz viz_typ req =
let _job_name = Dream.param "job" req let _job_name = Dream.param req "job"
and build = Dream.param "build" req and build = Dream.param req "build" in
and cachedir = Dream.global cachedir_global req in
get_uuid build >>= fun uuid -> get_uuid build >>= fun uuid ->
(try_load_cached_visualization ~cachedir ~uuid viz_typ try_load_cached_visualization ~cachedir ~uuid viz_typ
|> if_error "Error getting cached visualization") |> if_error "Error getting cached visualization"
>>= fun svg_html -> >>= fun svg_html ->
Lwt_result.ok (Dream.html svg_html) Lwt_result.ok (Dream.html svg_html)
in in
let job_build req = let job_build req =
let datadir = Dream.global datadir_global req in let job_name = Dream.param req "job"
let job_name = Dream.param "job" req and build = Dream.param req "build" in
and build = Dream.param "build" req in
get_uuid build >>= fun uuid -> get_uuid build >>= fun uuid ->
Dream.sql req (fun conn -> Dream.sql req (fun conn ->
Model.build uuid conn >>= fun (build_id, build) -> Model.build uuid conn >>= fun (build_id, build) ->
@ -261,11 +246,11 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let job_build_file req = let job_build_file req =
let datadir = Dream.global datadir_global req in let _job_name = Dream.param req "job"
let _job_name = Dream.param "job" req and build = Dream.param req "build"
and build = Dream.param "build" req (* FIXME *)
and filepath = Dream.path req |> String.concat "/" in and filepath = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in
let if_none_match = Dream.header "if-none-match" req in let if_none_match = Dream.header req "if-none-match" in
(* XXX: We don't check safety of [file]. This should be fine however since (* XXX: We don't check safety of [file]. This should be fine however since
* we don't use [file] for the filesystem but is instead used as a key for * we don't use [file] for the filesystem but is instead used as a key for
* lookup in the data table of the 'full' file. *) * lookup in the data table of the 'full' file. *)
@ -292,9 +277,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let job_build_static_file (file : [< `Console | `Script ]) req = let job_build_static_file (file : [< `Console | `Script ]) req =
let datadir = Dream.global datadir_global req in let _job_name = Dream.param req "job"
let _job_name = Dream.param "job" req and build = Dream.param req "build" in
and build = Dream.param "build" req in
get_uuid build >>= fun build -> get_uuid build >>= fun build ->
(match file with (match file with
| `Console -> | `Console ->
@ -309,10 +293,10 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let failed_builds req = let failed_builds req =
let platform = Dream.query "platform" req in let platform = Dream.query req "platform" in
let to_int default s = Option.(value ~default (bind s int_of_string_opt)) in let to_int default s = Option.(value ~default (bind s int_of_string_opt)) in
let start = to_int 0 (Dream.query "start" req) in let start = to_int 0 (Dream.query req "start") in
let count = to_int 10 (Dream.query "count" req) in let count = to_int 10 (Dream.query req "count") in
Dream.sql req (Model.failed_builds ~start ~count platform) Dream.sql req (Model.failed_builds ~start ~count platform)
|> if_error "Error getting data" |> if_error "Error getting data"
~log:(fun e -> Log.warn (fun m -> m "Error getting failed builds: %a" ~log:(fun e -> Log.warn (fun m -> m "Error getting failed builds: %a"
@ -322,9 +306,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let job_build_tar req = let job_build_tar req =
let datadir = Dream.global datadir_global req in let _job_name = Dream.param req "job"
let _job_name = Dream.param "job" req and build = Dream.param req "build" in
and build = Dream.param "build" req in
get_uuid build >>= fun build -> get_uuid build >>= fun build ->
Dream.sql req (Model.build build) Dream.sql req (Model.build build)
|> if_error "Error getting build" >>= fun (build_id, build) -> |> if_error "Error getting build" >>= fun (build_id, build) ->
@ -359,9 +342,7 @@ let add_routes ~datadir ~cachedir ~configdir =
(Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid) (Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid)
|> Lwt_result.ok |> Lwt_result.ok
| false -> | false ->
let datadir = Dream.global datadir_global req in (Lwt.return (Dream.field req Authorization.user_info_field |>
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, _) -> Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) ->
Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec)) Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec))
|> if_error "Internal server error" |> if_error "Internal server error"
@ -370,7 +351,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let hash req = let hash req =
Dream.query "sha256" req |> Option.to_result ~none:(`Msg "Missing sha256 query parameter") |> Lwt.return Dream.query req "sha256" |> Option.to_result ~none:(`Msg "Missing sha256 query parameter")
|> Lwt.return
|> if_error ~status:`Bad_Request "Bad request" >>= fun hash_hex -> |> if_error ~status:`Bad_Request "Bad request" >>= fun hash_hex ->
begin try Hex.to_cstruct (`Hex hash_hex) |> Lwt_result.return begin try Hex.to_cstruct (`Hex hash_hex) |> Lwt_result.return
with Invalid_argument e -> Lwt_result.fail (`Msg ("Bad hex: " ^ e)) with Invalid_argument e -> Lwt_result.fail (`Msg ("Bad hex: " ^ e))
@ -384,9 +366,8 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let compare_builds req = let compare_builds req =
let datadir = Dream.global datadir_global req in let build_left = Dream.param req "build_left" in
let build_left = Dream.param "build_left" req in let build_right = Dream.param req "build_right" in
let build_right = Dream.param "build_right" req in
get_uuid build_left >>= fun build_left -> get_uuid build_left >>= fun build_left ->
get_uuid build_right >>= fun build_right -> get_uuid build_right >>= fun build_right ->
Dream.sql req (fun conn -> Dream.sql req (fun conn ->
@ -429,10 +410,10 @@ let add_routes ~datadir ~cachedir ~configdir =
in in
let upload_binary req = let upload_binary req =
let job = Dream.param "job" req in let job = Dream.param req "job" in
let platform = Dream.param "platform" req in let platform = Dream.param req "platform" in
let binary_name = let binary_name =
Dream.query "binary_name" req Dream.query req "binary_name"
|> Option.map Fpath.of_string |> Option.map Fpath.of_string
|> Option.value ~default:(Ok Fpath.(v job + "bin")) |> Option.value ~default:(Ok Fpath.(v job + "bin"))
in in
@ -453,14 +434,12 @@ let add_routes ~datadir ~cachedir ~configdir =
(Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid) (Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid)
|> Lwt_result.ok |> Lwt_result.ok
| false -> | false ->
let datadir = Dream.global datadir_global req in
let cachedir = Dream.global cachedir_global req in
let exec = let exec =
let now = Ptime_clock.now () in let now = Ptime_clock.now () in
({ Builder.name = job ; platform ; script = "" }, uuid, [], now, now, Builder.Exited 0, ({ Builder.name = job ; platform ; script = "" }, uuid, [], now, now, Builder.Exited 0,
[ (Fpath.(v "bin" // binary_name), body) ]) [ (Fpath.(v "bin" // binary_name), body) ])
in in
(Lwt.return (Dream.local Authorization.user_info_local req |> (Lwt.return (Dream.field req Authorization.user_info_field |>
Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) -> Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) ->
Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec)) Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec))
|> if_error "Internal server error" |> if_error "Internal server error"
@ -484,7 +463,7 @@ let add_routes ~datadir ~cachedir ~configdir =
let w f req = or_error_response (f req) in let w f req = or_error_response (f req) in
Dream.router [ [
Dream.get "/" (w builds); Dream.get "/" (w builds);
Dream.get "/job" (w redirect_parent); Dream.get "/job" (w redirect_parent);
Dream.get "/job/:job" (w job); Dream.get "/job/:job" (w job);

25
lib/dream_tar.ml
View file

@ -1,16 +1,16 @@
open Lwt.Infix open Lwt.Infix
module Writer = struct module Writer = struct
type out_channel = Dream.response type out_channel = Dream.stream
type 'a t = 'a Lwt.t type 'a t = 'a Lwt.t
let really_write response cs = let really_write stream cs =
Dream.write response (Cstruct.to_string cs) Dream.write stream (Cstruct.to_string cs)
end end
module HW = Tar.HeaderWriter(Lwt)(Writer) module HW = Tar.HeaderWriter(Lwt)(Writer)
let write_block (header : Tar.Header.t) lpath response = let write_block (header : Tar.Header.t) lpath stream =
HW.write ~level:Tar.Header.Ustar header response >>= fun () -> HW.write ~level:Tar.Header.Ustar header stream >>= fun () ->
Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string lpath) >>= fun ic -> Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string lpath) >>= fun ic ->
let buf_len = 4 * 1024 * 1024 in let buf_len = 4 * 1024 * 1024 in
let buf = Bytes.create buf_len in let buf = Bytes.create buf_len in
@ -19,11 +19,11 @@ let write_block (header : Tar.Header.t) lpath response =
if r = 0 then if r = 0 then
Lwt.return_unit Lwt.return_unit
else else
Dream.write response (Bytes.sub_string buf 0 r) >>= fun () -> Dream.write stream (Bytes.sub_string buf 0 r) >>= fun () ->
loop () loop ()
in in
loop () >>= fun () -> loop () >>= fun () ->
Dream.write_buffer response (Cstruct.to_bigarray (Tar.Header.zero_padding header)) Dream.write stream (Cstruct.to_string (Tar.Header.zero_padding header))
let header_of_file mod_time (file : Builder_db.file) = let header_of_file mod_time (file : Builder_db.file) =
let file_mode = if Fpath.is_prefix Fpath.(v "bin/") file.filepath then let file_mode = if Fpath.is_prefix Fpath.(v "bin/") file.filepath then
@ -33,11 +33,12 @@ let header_of_file mod_time (file : Builder_db.file) =
in in
Tar.Header.make ~file_mode ~mod_time (Fpath.to_string file.filepath) (Int64.of_int file.size) Tar.Header.make ~file_mode ~mod_time (Fpath.to_string file.filepath) (Int64.of_int file.size)
let tar_response datadir finish (files : Builder_db.file list) (response : Dream.response) = let tar_response datadir finish (files : Builder_db.file list) (stream : Dream.stream) =
Lwt_list.iter_s (fun file -> Lwt_list.iter_s (fun file ->
let hdr = header_of_file finish file in let hdr = header_of_file finish file in
write_block hdr Fpath.(datadir // file.localpath) response) write_block hdr Fpath.(datadir // file.localpath) stream)
files >>= fun () -> files >>= fun () ->
Writer.really_write response Tar.Header.zero_block >>= fun () -> Writer.really_write stream Tar.Header.zero_block >>= fun () ->
Writer.really_write response Tar.Header.zero_block >>= fun () -> Writer.really_write stream Tar.Header.zero_block >>= fun () ->
Dream.close_stream response Dream.flush stream >>= fun () ->
Dream.close stream