Implemented a form on job-page for filtering platforms
This commit is contained in:
parent
637afde869
commit
05d3ccad82
2 changed files with 51 additions and 14 deletions
|
@ -278,29 +278,45 @@ let routes ~datadir ~cachedir ~configdir =
|
||||||
Views.Builds.make jobs |> string_of_html |> Dream.html |> Lwt_result.ok
|
Views.Builds.make jobs |> string_of_html |> Dream.html |> Lwt_result.ok
|
||||||
in
|
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 req =
|
||||||
let job_name = Dream.param req "job" in
|
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.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 ->
|
Dream.sql req (Model.builds_grouped_by_output job_id platform) >|= fun builds ->
|
||||||
(readme, builds))
|
(readme, builds, platforms))
|
||||||
|> if_error "Error getting job"
|
|> if_error "Error getting job"
|
||||||
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
|
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
|
||||||
>>= fun (readme, builds) ->
|
>>= fun (readme, builds, platforms) ->
|
||||||
Views.Job.make ~failed:false ~job_name ~platform ~readme builds
|
Views.Job.make ~failed:false ~job_name ~platform ~platforms ~readme builds
|
||||||
|> string_of_html |> Dream.html |> Lwt_result.ok
|
|> string_of_html |> Dream.html |> Lwt_result.ok
|
||||||
in
|
in
|
||||||
|
|
||||||
let job_with_failed req =
|
let job_with_failed req =
|
||||||
let job_name = Dream.param req "job" in
|
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.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 ->
|
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"
|
|> if_error "Error getting job"
|
||||||
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
|
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
|
||||||
>>= fun (readme, builds) ->
|
>>= fun (readme, builds, platforms) ->
|
||||||
Views.Job.make ~failed:true ~job_name ~platform ~readme builds
|
Views.Job.make ~failed:true ~job_name ~platform ~platforms ~readme builds
|
||||||
|> string_of_html |> Dream.html |> Lwt_result.ok
|
|> string_of_html |> Dream.html |> Lwt_result.ok
|
||||||
in
|
in
|
||||||
|
|
||||||
|
|
33
lib/views.ml
33
lib/views.ml
|
@ -413,10 +413,30 @@ module Job = struct
|
||||||
build.Builder_db.Build.result ]
|
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.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));
|
H.ul (builds |> List.map (make_build ~job_name));
|
||||||
let queries =
|
let queries =
|
||||||
platform |> Option.map (fun p -> `Platform p) |> Option.to_list
|
platform |> Option.map (fun p -> `Platform p) |> Option.to_list
|
||||||
|
@ -439,14 +459,15 @@ module Job = struct
|
||||||
H.txt "." ]
|
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_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 nav = `Job (job_name, platform) in
|
||||||
let title = Fmt.str "Job %s %a" job_name pp_platform 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
|
end
|
||||||
|
|
Loading…
Reference in a new issue