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

Implemented a form on job-page for filtering platforms

Browse source
This commit is contained in:
rand00 2022-08-03 12:29:15 +02:00
parent 637afde869
commit 05d3ccad82
2 changed files with 51 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
lib/builder_web.ml
View file

@ -278,29 +278,45 @@ let routes ~datadir ~cachedir ~configdir =
Views.Builds.make jobs |> string_of_html |> Dream.html |> Lwt_result.ok
in
let remove_empty_param param_opt =
Option.bind param_opt (fun p -> if p = "" then None else Some p)
in
let job req =
let job_name = Dream.param req "job" in
let platform = Dream.query req "platform" in
let platform = Dream.query req "platform" |> remove_empty_param in
(Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
Dream.sql req (Model.builds_grouped_by_output job_id None) >>= fun all_builds ->
let platforms =
all_builds
|> List.map (fun (build, _) -> build.Builder_db.Build.platform)
|> List.sort_uniq String.compare
in
Dream.sql req (Model.builds_grouped_by_output job_id platform) >|= fun builds ->
(readme, builds))
(readme, builds, platforms))
|> if_error "Error getting job"
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
>>= fun (readme, builds) ->
Views.Job.make ~failed:false ~job_name ~platform ~readme builds
>>= fun (readme, builds, platforms) ->
Views.Job.make ~failed:false ~job_name ~platform ~platforms ~readme builds
|> string_of_html |> Dream.html |> Lwt_result.ok
in
let job_with_failed req =
let job_name = Dream.param req "job" in
let platform = Dream.query req "platform" in
let platform = Dream.query req "platform" |> remove_empty_param in
(Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
Dream.sql req (Model.builds_grouped_by_output job_id None) >>= fun all_builds ->
let platforms =
all_builds
|> List.map (fun (build, _) -> build.Builder_db.Build.platform)
|> List.sort_uniq String.compare
in
Dream.sql req (Model.builds_grouped_by_output_with_failed job_id platform) >|= fun builds ->
(readme, builds))
(readme, builds, platforms))
|> if_error "Error getting job"
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
>>= fun (readme, builds) ->
Views.Job.make ~failed:true ~job_name ~platform ~readme builds
>>= fun (readme, builds, platforms) ->
Views.Job.make ~failed:true ~job_name ~platform ~platforms ~readme builds
|> string_of_html |> Dream.html |> Lwt_result.ok
in

33
lib/views.ml
View file

@ -413,10 +413,30 @@ module Job = struct
build.Builder_db.Build.result ]
)
let make_builds ~failed ~job_name ~platform builds =
let make_builds ~failed ~job_name ~platform ~platforms builds =
let all_platforms =
H.option ~a:H.[ a_value "" ] (H.txt "All platforms")
in
[
H.h2 ~a:H.[a_id "builds"] [H.txt "Builds"];
H.a ~a:H.[a_href "#readme"] [H.txt "Back to readme"];
(* H.a ~a:H.[a_href "#readme"] [H.txt "Back to readme"]; *)
H.form ~a:H.[
a_action @@ "";
a_method `Get;
] [
H.label ~a:H.[a_label_for "filter-platform"] [H.txt "Filter platform: "];
H.select ~a:H.[
a_name "platform";
a_id "filter-platform";
]
(all_platforms :: (platforms |> List.map (fun platform ->
H.option ~a:H.[ a_value platform ] (H.txt platform)
)));
H.input ~a:H.[
a_input_type `Submit;
a_value "Apply";
] ();
];
H.ul (builds |> List.map (make_build ~job_name));
let queries =
platform |> Option.map (fun p -> `Platform p) |> Option.to_list
@ -439,14 +459,15 @@ module Job = struct
H.txt "." ]
]
let make_body ~failed ~job_name ~platform ~readme builds =
let make_body ~failed ~job_name ~platform ~platforms ~readme builds =
make_header ~job_name ~platform ~readme
@ make_builds ~failed ~job_name ~platform builds
@ make_builds ~failed ~job_name ~platform ~platforms builds
let make ~failed ~job_name ~platform ~readme builds =
let make ~failed ~job_name ~platform ~readme ~platforms builds =
let nav = `Job (job_name, platform) in
let title = Fmt.str "Job %s %a" job_name pp_platform platform in
layout ~nav ~title @@ make_body ~failed ~job_name ~platform ~readme builds
layout ~nav ~title
@@ make_body ~failed ~job_name ~platform ~platforms ~readme builds
end