New centered flex-layout for builds page with 2 columns + some refactorings around Views
This commit is contained in:
rand00
parent
915468bbf1
commit
c80ee590bd
2 changed files with 215 additions and 145 deletions
|
|
@ -136,7 +136,7 @@ let add_routes datadir =
|
||||||
|> 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) ->
|
||||||
Views.job ~failed:false job_name platform readme builds |> string_of_html |> Dream.html |> Lwt_result.ok
|
Views.Job.make ~failed:false job_name platform readme builds |> string_of_html |> Dream.html |> Lwt_result.ok
|
||||||
in
|
in
|
||||||
|
|
||||||
let job_with_failed req =
|
let job_with_failed req =
|
||||||
|
|
@ -148,7 +148,7 @@ let add_routes datadir =
|
||||||
|> 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) ->
|
||||||
Views.job ~failed:true job_name platform readme builds |> string_of_html |> Dream.html |> Lwt_result.ok
|
Views.Job.make ~failed:true job_name platform readme builds |> string_of_html |> Dream.html |> Lwt_result.ok
|
||||||
in
|
in
|
||||||
|
|
||||||
let redirect_latest req =
|
let redirect_latest req =
|
||||||
|
|
@ -271,7 +271,14 @@ let add_routes datadir =
|
||||||
|> if_error "Error getting job build"
|
|> if_error "Error getting job build"
|
||||||
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
|
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
|
||||||
>>= fun (build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest, next, previous) ->
|
>>= fun (build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest, next, previous) ->
|
||||||
Views.job_build job_name build artifacts same_input_same_output different_input_same_output same_input_different_output latest next previous
|
Views.Job.Build.make
|
||||||
|
~name:job_name
|
||||||
|
~build
|
||||||
|
~artifacts
|
||||||
|
~same_input_same_output
|
||||||
|
~different_input_same_output
|
||||||
|
~same_input_different_output
|
||||||
|
~latest ~next ~previous
|
||||||
|> string_of_html |> Dream.html |> Lwt_result.ok
|
|> string_of_html |> Dream.html |> Lwt_result.ok
|
||||||
in
|
in
|
||||||
|
|
||||||
|
|
|
||||||
345
lib/views.ml
345
lib/views.ml
|
|
@ -306,155 +306,218 @@ let markdown_to_html data =
|
||||||
let omd = safe_omd omd in
|
let omd = safe_omd omd in
|
||||||
Omd.to_html omd
|
Omd.to_html omd
|
||||||
|
|
||||||
let job ~failed name platform readme builds =
|
module Job = struct
|
||||||
layout ~nav:(`Job (name, platform)) ~title:(Fmt.str "Job %s %a" name pp_platform platform)
|
|
||||||
((h1 [txtf "Job %s %a" name pp_platform platform] ::
|
|
||||||
(match readme with
|
|
||||||
| None -> []
|
|
||||||
| Some data ->
|
|
||||||
[
|
|
||||||
h2 ~a:[a_id "readme"] [txt "README"];
|
|
||||||
a ~a:[a_href "#builds"] [txt "Skip to builds"];
|
|
||||||
Unsafe.data (markdown_to_html data)
|
|
||||||
])) @
|
|
||||||
[
|
|
||||||
h2 ~a:[a_id "builds"] [txt "Builds"];
|
|
||||||
a ~a:[a_href "#readme"] [txt "Back to readme"];
|
|
||||||
ul (List.map (fun (build, main_binary) ->
|
|
||||||
li ([
|
|
||||||
check_icon build.Builder_db.Build.result;
|
|
||||||
txtf " %s " build.platform;
|
|
||||||
a ~a:[Fmt.kstr a_href "/job/%s/build/%a/" name Uuidm.pp build.Builder_db.Build.uuid]
|
|
||||||
[
|
|
||||||
txtf "%a" pp_ptime build.Builder_db.Build.start;
|
|
||||||
];
|
|
||||||
txt " ";
|
|
||||||
] @ match main_binary with
|
|
||||||
| Some main_binary ->
|
|
||||||
artifact ~basename:true name build main_binary
|
|
||||||
| None ->
|
|
||||||
[ txtf "Build failure: %a" Builder.pp_execution_result
|
|
||||||
build.Builder_db.Build.result ]))
|
|
||||||
builds);
|
|
||||||
if failed then
|
|
||||||
p [ txt "Excluding failed builds " ; a ~a:[a_href "../"] [txt "here"] ; txt "." ]
|
|
||||||
else
|
|
||||||
p [ txt "Including failed builds " ; a ~a:[a_href "failed/"] [txt "here"] ; txt "." ]
|
|
||||||
])
|
|
||||||
|
|
||||||
let contains_debug_bin artifacts =
|
let make ~failed name platform readme builds =
|
||||||
let check f =
|
layout ~nav:(`Job (name, platform)) ~title:(Fmt.str "Job %s %a" name pp_platform platform)
|
||||||
Fpath.has_ext "debug" f.Builder_db.filepath
|
((h1 [txtf "Job %s %a" name pp_platform platform] ::
|
||||||
in
|
(match readme with
|
||||||
List.find_opt check artifacts |> CCOption.is_some
|
| None -> []
|
||||||
|
| Some data ->
|
||||||
|
[
|
||||||
|
h2 ~a:[a_id "readme"] [txt "README"];
|
||||||
|
a ~a:[a_href "#builds"] [txt "Skip to builds"];
|
||||||
|
Unsafe.data (markdown_to_html data)
|
||||||
|
])) @
|
||||||
|
[
|
||||||
|
h2 ~a:[a_id "builds"] [txt "Builds"];
|
||||||
|
a ~a:[a_href "#readme"] [txt "Back to readme"];
|
||||||
|
ul (List.map (fun (build, main_binary) ->
|
||||||
|
li ([
|
||||||
|
check_icon build.Builder_db.Build.result;
|
||||||
|
txtf " %s " build.platform;
|
||||||
|
a ~a:[Fmt.kstr a_href "/job/%s/build/%a/" name Uuidm.pp build.Builder_db.Build.uuid]
|
||||||
|
[
|
||||||
|
txtf "%a" pp_ptime build.Builder_db.Build.start;
|
||||||
|
];
|
||||||
|
txt " ";
|
||||||
|
] @ match main_binary with
|
||||||
|
| Some main_binary ->
|
||||||
|
artifact ~basename:true name build main_binary
|
||||||
|
| None ->
|
||||||
|
[ txtf "Build failure: %a" Builder.pp_execution_result
|
||||||
|
build.Builder_db.Build.result ]))
|
||||||
|
builds);
|
||||||
|
if failed then
|
||||||
|
p [ txt "Excluding failed builds " ; a ~a:[a_href "../"] [txt "here"] ; txt "." ]
|
||||||
|
else
|
||||||
|
p [ txt "Including failed builds " ; a ~a:[a_href "failed/"] [txt "here"] ; txt "." ]
|
||||||
|
])
|
||||||
|
|
||||||
let job_build
|
let contains_debug_bin artifacts =
|
||||||
name
|
let check f =
|
||||||
({ Builder_db.Build.uuid; start; finish; result; platform; _ } as build)
|
Fpath.has_ext "debug" f.Builder_db.filepath
|
||||||
artifacts
|
in
|
||||||
same_input_same_output different_input_same_output same_input_different_output
|
List.find_opt check artifacts |> CCOption.is_some
|
||||||
latest next previous
|
|
||||||
=
|
module Build = struct
|
||||||
let delta = Ptime.diff finish start in
|
|
||||||
let analysis_section = [
|
let make_build_info
|
||||||
[ h3 [txt "Analysis"] ];
|
~name
|
||||||
if not @@ contains_debug_bin artifacts then [] else [
|
~delta
|
||||||
p [
|
~(build:Builder_db.Build.t) (* ({ Builder_db.Build.uuid; start; finish; result; platform; _ } as build) *)
|
||||||
let src = Fmt.str "/job/%s/build/%a/viztreemap" name Uuidm.pp uuid in
|
~artifacts
|
||||||
let style = "width: 50em; height: 54.0em" in (*treemap tries to be square*)
|
~same_input_same_output
|
||||||
iframe ~a:[ a_src src; a_title "Binary dissection"; a_style style ] []
|
~different_input_same_output
|
||||||
]
|
~same_input_different_output
|
||||||
];
|
~latest ~next ~previous
|
||||||
[ p [
|
=
|
||||||
let src = Fmt.str "/job/%s/build/%a/vizdependencies" name Uuidm.pp uuid in
|
[
|
||||||
let style = "width: 50em; height: 50.5em" in
|
h2 ~a:[a_id "build"] [txtf "Build %a" pp_ptime build.start];
|
||||||
iframe ~a:[ a_src src; a_title "Opam dependencies"; a_style style ] [] ]];
|
p [txtf "Built on platform %s" build.platform ];
|
||||||
] |> List.flatten
|
p [txtf "Build took %a." Ptime.Span.pp delta ];
|
||||||
in
|
p [txtf "Execution result: %a." Builder.pp_execution_result build.result];
|
||||||
let body =
|
h3 [txt "Build info"];
|
||||||
h1 [txtf "Job %s" name] ::
|
ul [
|
||||||
[
|
li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp build.uuid]
|
||||||
h2 ~a:[a_id "build"] [txtf "Build %a" pp_ptime start];
|
[txt "Console output"];
|
||||||
p [txtf "Built on platform %s" platform ];
|
];
|
||||||
p [txtf "Build took %a." Ptime.Span.pp delta ];
|
li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/script" name Uuidm.pp build.uuid]
|
||||||
p [txtf "Execution result: %a." Builder.pp_execution_result result];
|
[txt "Build script"];
|
||||||
] @ analysis_section @ [
|
]
|
||||||
h3 [txt "Build info"];
|
|
||||||
ul [
|
|
||||||
li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp uuid]
|
|
||||||
[txt "Console output"];
|
|
||||||
];
|
];
|
||||||
li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/script" name Uuidm.pp uuid]
|
h3 [txt "Build artifacts"];
|
||||||
[txt "Build script"];
|
dl (List.concat_map
|
||||||
]
|
(fun { Builder_db.filepath; localpath=_; sha256; size } ->
|
||||||
];
|
let (`Hex sha256_hex) = Hex.of_cstruct sha256 in
|
||||||
h3 [txt "Build artifacts"];
|
[
|
||||||
dl (List.concat_map
|
dt [a
|
||||||
(fun { Builder_db.filepath; localpath=_; sha256; size } ->
|
~a:[Fmt.kstr a_href "f/%a" Fpath.pp filepath]
|
||||||
let (`Hex sha256_hex) = Hex.of_cstruct sha256 in
|
[code [txtf "%a" Fpath.pp filepath]]];
|
||||||
[
|
dd [
|
||||||
dt [a
|
code [txt "SHA256:"; txt sha256_hex];
|
||||||
~a:[Fmt.kstr a_href "f/%a" Fpath.pp filepath]
|
txtf " (%a)" Fmt.byte_size size;
|
||||||
[code [txtf "%a" Fpath.pp filepath]]];
|
];
|
||||||
dd [
|
])
|
||||||
code [txt "SHA256:"; txt sha256_hex];
|
artifacts);
|
||||||
txtf " (%a)" Fmt.byte_size size;
|
h3 [ txtf "Reproduced by %d builds" (List.length (same_input_same_output @ different_input_same_output))] ;
|
||||||
];
|
ul
|
||||||
])
|
((List.map (fun { Builder_db.Build.start ; uuid ; platform ; _ } ->
|
||||||
artifacts);
|
|
||||||
h3 [ txtf "Reproduced by %d builds" (List.length (same_input_same_output @ different_input_same_output))] ;
|
|
||||||
ul
|
|
||||||
((List.map (fun { Builder_db.Build.start ; uuid ; platform ; _ } ->
|
|
||||||
li [
|
|
||||||
txtf "on %s, same input, " platform;
|
|
||||||
a ~a:[Fmt.kstr a_href "/job/%s/build/%a/" name Uuidm.pp uuid]
|
|
||||||
[txtf "%a" pp_ptime start]
|
|
||||||
])
|
|
||||||
same_input_same_output) @
|
|
||||||
List.map (fun { Builder_db.Build.start ; uuid = other_uuid ; platform ; _ } ->
|
|
||||||
li [
|
|
||||||
txtf "on %s, different input, " platform;
|
|
||||||
a ~a:[Fmt.kstr a_href "/compare/%a/%a/"
|
|
||||||
Uuidm.pp other_uuid Uuidm.pp uuid]
|
|
||||||
[txtf "%a" pp_ptime start]
|
|
||||||
])
|
|
||||||
different_input_same_output)
|
|
||||||
] @
|
|
||||||
(if same_input_different_output = [] then
|
|
||||||
[]
|
|
||||||
else
|
|
||||||
[ h3 [txt "Same input, different output (not reproducible!)"];
|
|
||||||
ul (
|
|
||||||
List.map (fun { Builder_db.Build.start ; uuid = other_uuid ; platform ; _ } ->
|
|
||||||
li [
|
li [
|
||||||
txtf "on %s, " platform ;
|
txtf "on %s, same input, " platform;
|
||||||
a ~a:[Fmt.kstr a_href "/compare/%a/%a/" Uuidm.pp other_uuid Uuidm.pp uuid]
|
a ~a:[Fmt.kstr a_href "/job/%s/build/%a/" name Uuidm.pp uuid]
|
||||||
[txtf "%a" pp_ptime start]
|
[txtf "%a" pp_ptime start]
|
||||||
])
|
])
|
||||||
same_input_different_output)
|
same_input_same_output) @
|
||||||
]) @
|
List.map (fun { Builder_db.Build.start ; uuid = other_uuid ; platform ; _ } ->
|
||||||
[ h3 [txt "Comparisons with other builds on the same platform"];
|
li [
|
||||||
let opt_build (ctx, build) =
|
txtf "on %s, different input, " platform;
|
||||||
match build with
|
a ~a:[Fmt.kstr a_href "/compare/%a/%a/"
|
||||||
| Some b when not (Uuidm.equal uuid b.Builder_db.Build.uuid) ->
|
Uuidm.pp other_uuid Uuidm.pp build.uuid]
|
||||||
[ li [ txt ctx;
|
[txtf "%a" pp_ptime start]
|
||||||
a ~a:[Fmt.kstr a_href "/compare/%a/%a/"
|
])
|
||||||
Uuidm.pp b.uuid Uuidm.pp uuid]
|
different_input_same_output)
|
||||||
[txtf "%a" pp_ptime b.start]]
|
]
|
||||||
|
@ (if same_input_different_output = [] then
|
||||||
|
[]
|
||||||
|
else
|
||||||
|
[ h3 [txt "Same input, different output (not reproducible!)"];
|
||||||
|
ul (
|
||||||
|
List.map (fun { Builder_db.Build.start ; uuid = other_uuid ; platform ; _ } ->
|
||||||
|
li [
|
||||||
|
txtf "on %s, " platform ;
|
||||||
|
a ~a:[Fmt.kstr a_href "/compare/%a/%a/" Uuidm.pp other_uuid Uuidm.pp build.uuid]
|
||||||
|
[txtf "%a" pp_ptime start]
|
||||||
|
])
|
||||||
|
same_input_different_output)
|
||||||
]
|
]
|
||||||
| _ -> []
|
)
|
||||||
|
@ [
|
||||||
|
h3 [txt "Comparisons with other builds on the same platform"];
|
||||||
|
let opt_build (ctx, build') =
|
||||||
|
match build' with
|
||||||
|
| Some b when not (Uuidm.equal build.uuid b.Builder_db.Build.uuid) ->
|
||||||
|
[ li [ txt ctx;
|
||||||
|
a ~a:[Fmt.kstr a_href "/compare/%a/%a/"
|
||||||
|
Uuidm.pp b.uuid Uuidm.pp build.uuid]
|
||||||
|
[txtf "%a" pp_ptime b.start]]
|
||||||
|
]
|
||||||
|
| _ -> []
|
||||||
|
in
|
||||||
|
ul
|
||||||
|
(List.concat_map opt_build
|
||||||
|
[ ("Latest build ", latest) ;
|
||||||
|
("Later build with different output ", next) ;
|
||||||
|
("Earlier build with different output ", previous) ])
|
||||||
|
]
|
||||||
|
|
||||||
|
let viz_style = "
|
||||||
|
width: 46em;
|
||||||
|
height: 50em;
|
||||||
|
max-width: 100%;
|
||||||
|
max-height: 52vw;
|
||||||
|
min-width: 38em;
|
||||||
|
min-height: 41em;
|
||||||
|
"
|
||||||
|
|
||||||
|
let make_viz_section ~name ~artifacts ~uuid =
|
||||||
|
[
|
||||||
|
(* [ h3 [txt "Analysis"] ]; *)
|
||||||
|
if not @@ contains_debug_bin artifacts then [] else [
|
||||||
|
p [
|
||||||
|
let src = Fmt.str "/job/%s/build/%a/viztreemap" name Uuidm.pp uuid in
|
||||||
|
iframe ~a:[ a_src src; a_title "Binary dissection"; a_style viz_style ] []
|
||||||
|
]
|
||||||
|
];
|
||||||
|
[ p [
|
||||||
|
let src = Fmt.str "/job/%s/build/%a/vizdependencies" name Uuidm.pp uuid in
|
||||||
|
iframe ~a:[ a_src src; a_title "Opam dependencies"; a_style viz_style ] [] ]];
|
||||||
|
] |> List.flatten
|
||||||
|
|
||||||
|
let make
|
||||||
|
~name
|
||||||
|
~(build:Builder_db.Build.t)
|
||||||
|
~artifacts
|
||||||
|
~same_input_same_output
|
||||||
|
~different_input_same_output
|
||||||
|
~same_input_different_output
|
||||||
|
~latest ~next ~previous
|
||||||
|
=
|
||||||
|
let delta = Ptime.diff build.finish build.start in
|
||||||
|
let right_column = make_viz_section ~name ~artifacts ~uuid:build.uuid in
|
||||||
|
let left_column =
|
||||||
|
make_build_info
|
||||||
|
~name
|
||||||
|
~delta
|
||||||
|
~build
|
||||||
|
~artifacts
|
||||||
|
~same_input_same_output
|
||||||
|
~different_input_same_output
|
||||||
|
~same_input_different_output
|
||||||
|
~latest ~next ~previous
|
||||||
in
|
in
|
||||||
ul
|
let style_grid = a_style "display: flex; " in
|
||||||
(List.concat_map opt_build
|
let style_grid_container = a_style "\
|
||||||
[ ("Latest build ", latest) ;
|
display: flex;
|
||||||
("Later build with different output ", next) ;
|
align-items: center;
|
||||||
("Earlier build with different output ", previous) ])
|
justify-content: center;
|
||||||
]
|
min-width: 83em;
|
||||||
in
|
"
|
||||||
layout
|
in
|
||||||
~nav:(`Build (name, build))
|
let style_col_container = a_style "" in
|
||||||
~title:(Fmt.str "Job %s %a" name pp_ptime start)
|
let style_col_left = a_style "width: 45em; min-width: 43em; padding-left: 2%" in
|
||||||
body
|
let style_col_right = a_style "width: 50%" in
|
||||||
|
let body = [
|
||||||
|
div ~a:[ style_grid_container ] [
|
||||||
|
div ~a:[ style_col_container ] [
|
||||||
|
h1 [txtf "Job %s" name];
|
||||||
|
div ~a:[ style_grid ] [
|
||||||
|
(* div ~a:[ style_col_padding ] []; *)
|
||||||
|
div ~a:[ style_col_left ] left_column;
|
||||||
|
div ~a:[ style_col_right ] right_column
|
||||||
|
]
|
||||||
|
]
|
||||||
|
]
|
||||||
|
]
|
||||||
|
in
|
||||||
|
layout
|
||||||
|
~nav:(`Build (name, build))
|
||||||
|
~title:(Fmt.str "Job %s %a" name pp_ptime build.start)
|
||||||
|
body
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
let key_values xs =
|
let key_values xs =
|
||||||
List.concat_map (fun (k, v) -> [ txtf "%s %s" k v ; br () ]) xs
|
List.concat_map (fun (k, v) -> [ txtf "%s %s" k v ; br () ]) xs
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue