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

Made all links safe via a Links module

Browse source
This commit is contained in:
rand00 2022-06-07 16:43:44 +02:00 committed by Reynir Björnsson
parent 08b16adb1f
commit 93dc0d6d87
3 changed files with 185 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
lib/builder_web.ml
View file

@ -306,13 +306,13 @@ let routes ~datadir ~cachedir ~configdir =
let job_name = Dream.param req "job" in
let platform = Dream.query req "platform" in
(* FIXME *)
let path = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in
let artifact = 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.latest_successful_build_uuid job_id platform))
>>= Model.not_found
|> if_error "Error getting job" >>= fun build ->
Dream.redirect req
(Fmt.str "/job/%s/build/%a/%s" job_name Uuidm.pp build path)
(Link.Job_build_artifact.make_from_string ~job_name ~build ~artifact ())
|> Lwt_result.ok
in
@ -321,9 +321,9 @@ let routes ~datadir ~cachedir ~configdir =
and build = Dream.param req "build" in
get_uuid build >>= fun uuid ->
Dream.sql req (main_binary_of_uuid uuid) >>= fun main_binary ->
Dream.redirect req
(Fmt.str "/job/%s/build/%a/f/%a" job_name Uuidm.pp uuid
Fpath.pp main_binary.Builder_db.filepath)
let filepath = main_binary.Builder_db.filepath in
Link.Job_build_f.make ~job_name ~build:uuid ~filepath ()
|> Dream.redirect req
|> Lwt_result.ok
in
@ -360,7 +360,7 @@ let routes ~datadir ~cachedir ~configdir =
>>= fun (build, main_binary, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest, next, previous) ->
let solo5_manifest = Option.bind main_binary (Model.solo5_manifest datadir) in
Views.Job_build.make
~name:job_name
~job_name
~build
~artifacts
~main_binary
@ -488,7 +488,7 @@ let routes ~datadir ~cachedir ~configdir =
Dream.sql req (Model.build_hash hash) >>= Model.not_found
|> if_error "Internal server error" >>= fun (job_name, build) ->
Dream.redirect req
(Fmt.str "/job/%s/build/%a" job_name Uuidm.pp build.Builder_db.Build.uuid)
(Link.Job_build.make ~job_name ~build:build.Builder_db.Build.uuid ())
|> Lwt_result.ok
in

98
lib/link.ml Normal file
View file

@ -0,0 +1,98 @@
let fpath_url_pp ppf f =
Fpath.segs f
|> List.map Uri.pct_encode
|> Fmt.(list ~sep:(any "/") string) ppf
module Queries_aux = struct
let flatten = Option.value ~default:[]
let add_raw url_str queries =
let uri = Uri.of_string url_str in
let uri = Uri.add_query_params uri queries in
Uri.to_string uri
let add ~encode_query queries url_str =
queries |> flatten |> List.map encode_query |> add_raw url_str
end
let pctencode fmt str = Format.fprintf fmt "%s" (Uri.pct_encode str)
module Root = struct
let make () = "/"
end
module Job = struct
let encode_query = function
| `Platform p -> "platform", [ p ]
let make ?queries ~job_name () =
Fmt.str "/job/%a" pctencode job_name
|> Queries_aux.add ~encode_query queries
let make_failed ?queries ~job_name () =
Fmt.str "/job/%a/failed" pctencode job_name
|> Queries_aux.add ~encode_query queries
end
module Job_build = struct
let make ~job_name ~build () =
Fmt.str "/job/%a/build/%a"
pctencode job_name
Uuidm.pp build
end
module Job_build_artifact = struct
let encode_artifact = function
| `Main_binary -> "main-binary"
| `Viz_treemap -> "viztreemap"
| `Viz_dependencies -> "vizdependencies"
| `Script -> "script"
| `Console -> "console"
| `All_targz -> "all.tar.gz"
let make_from_string ~job_name ~build ~artifact () =
Fmt.str "/job/%a/build/%a/%s"
pctencode job_name
Uuidm.pp build
artifact
let make ~job_name ~build ~artifact () =
let artifact = encode_artifact artifact in
make_from_string ~job_name ~build ~artifact ()
end
module Job_build_f = struct
let make ~job_name ~build ~filepath () =
Fmt.str "/job/%a/build/%a/f/%a"
pctencode job_name
Uuidm.pp build
fpath_url_pp filepath
end
module Compare_builds = struct
let make ~left ~right () =
Fmt.str "/compare/%a/%a"
Uuidm.pp left
Uuidm.pp right
end
module Failed_builds = struct
let make ~count ~start () =
Fmt.str "/failed-builds?count=%d&start=%d" count start
end

156
lib/views.ml
View file

@ -31,8 +31,6 @@ type nav = [
let pp_platform =
Fmt.(option ~none:(any "") (append (any "on ") string))
let pp_platform_query =
Fmt.(option ~none:(any "") (append (any "?platform=") string))
let static_css = Tyxml.Html.Unsafe.data {|
body {
@ -93,29 +91,28 @@ let make_breadcrumbs nav =
| `Default ->
to_nav [H.txt "Home", "/"]
| `Job (job_name, platform) ->
let queries =
platform |> Option.map (fun v -> `Platform v) |> Option.to_list in
to_nav [
H.txt "Home", "/";
txtf "Job %s" job_name, Fmt.str "/job/%s" job_name ;
txtf "Job %s" job_name, Link.Job.make ~job_name ();
(
txtf "%a" pp_platform platform,
Fmt.str "/job/%s/%a" job_name pp_platform_query platform
Link.Job.make ~job_name ~queries ()
)
]
| `Build (job_name, build) ->
to_nav [
H.txt "Home", "/";
txtf "Job %s" job_name, Fmt.str "/job/%s" job_name;
txtf "Job %s" job_name, Link.Job.make ~job_name ();
(
txtf "%a" pp_platform (Some build.Builder_db.Build.platform),
Fmt.str "/job/%s/%a"
job_name
pp_platform_query (Some build.Builder_db.Build.platform)
Link.Job.make ~job_name
~queries:[ `Platform build.Builder_db.Build.platform ] ()
);
(
txtf "Build %a" pp_ptime build.Builder_db.Build.start,
Fmt.str "/job/%s/build/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid
Link.Job_build.make ~job_name ~build:build.Builder_db.Build.uuid ()
);
]
| `Comparison ((job_left, build_left), (job_right, build_right)) ->
@ -125,9 +122,9 @@ let make_breadcrumbs nav =
txtf "Comparison between %s@%a and %s@%a"
job_left pp_ptime build_left.Builder_db.Build.start
job_right pp_ptime build_right.Builder_db.Build.start,
Fmt.str "/compare/%a/%a"
Uuidm.pp build_left.uuid
Uuidm.pp build_right.uuid
Link.Compare_builds.make
~left:build_left.uuid
~right:build_right.uuid ()
);
]
@ -194,10 +191,10 @@ let artifact
~file:{ Builder_db.filepath; localpath = _; sha256; size }
=
let artifact_link =
Fmt.str "/job/%s/build/%a/f/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid
Fpath.pp filepath
Link.Job_build_f.make
~job_name
~build:build.Builder_db.Build.uuid
~filepath ()
in
[
H.a ~a:H.[a_href artifact_link] [
@ -297,15 +294,15 @@ have questions or suggestions.
check_icon latest_build.Builder_db.Build.result;
H.txt " ";
H.a ~a:[
Fmt.kstr H.a_href "/job/%s/%a"
job_name
pp_platform_query (Some platform)]
H.a_href @@ Link.Job.make ~job_name
~queries:[ `Platform platform ] ()
]
[H.txt platform];
H.txt " ";
H.a ~a:[
Fmt.kstr H.a_href "/job/%s/build/%a/"
job_name
Uuidm.pp latest_build.Builder_db.Build.uuid]
H.a_href @@ Link.Job_build.make
~job_name
~build:latest_build.Builder_db.Build.uuid ()]
[txtf "%a" pp_ptime latest_build.Builder_db.Build.start];
H.txt " ";
]
@ -382,9 +379,9 @@ module Job = struct
check_icon build.Builder_db.Build.result;
txtf " %s " build.platform;
H.a ~a:H.[
Fmt.kstr a_href "/job/%s/build/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid ]
a_href @@ Link.Job_build.make
~job_name
~build:build.Builder_db.Build.uuid () ]
[
txtf "%a" pp_ptime build.Builder_db.Build.start;
];
@ -407,13 +404,14 @@ module Job = struct
H.h2 ~a:H.[a_id "builds"] [H.txt "Builds"];
H.a ~a:H.[a_href "#readme"] [H.txt "Back to readme"];
H.ul (builds |> List.map (make_build ~job_name));
let queries =
platform |> Option.map (fun p -> `Platform p) |> Option.to_list
in
if failed then
H.p [
H.txt "Excluding failed builds " ;
H.a ~a:H.[
a_href @@ Fmt.str "/job/%s%a"
job_name
pp_platform_query platform
a_href @@ Link.Job.make ~job_name ~queries ()
]
[H.txt "here"] ;
H.txt "." ]
@ -421,9 +419,7 @@ module Job = struct
H.p [
H.txt "Including failed builds " ;
H.a ~a:H.[
a_href @@ Fmt.str "/job/%s/failed%a"
job_name
pp_platform_query platform
a_href @@ Link.Job.make_failed ~job_name ~queries ()
]
[H.txt "here"] ;
H.txt "." ]
@ -480,10 +476,10 @@ module Job_build = struct
let (`Hex sha256_hex) = Hex.of_cstruct file.sha256 in
[
H.dt [
H.a ~a:H.[Fmt.kstr a_href "/job/%s/build/%a/f/%a"
job_name
Uuidm.pp build_uuid
Fpath.pp file.filepath
H.a ~a:H.[a_href @@ Link.Job_build_f.make
~job_name
~build:build_uuid
~filepath:file.filepath ()
]
[H.code [txtf "%a" Fpath.pp file.filepath]] ];
H.dd ([
@ -502,7 +498,7 @@ module Job_build = struct
]
let make_reproductions
~name
~job_name
~(build:Builder_db.Build.t)
~same_input_same_output
~different_input_same_output
@ -511,7 +507,7 @@ module Job_build = struct
List.map (fun (build:Builder_db.Build.t) ->
H.li [
txtf "on %s, same input, " build.platform;
H.a ~a:H.[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp build.uuid]
H.a ~a:H.[a_href @@ Link.Job_build.make ~job_name ~build:build.uuid ()]
[txtf "%a" pp_ptime build.start]
])
same_input_same_output
@ -521,9 +517,9 @@ module Job_build = struct
H.li [
txtf "on %s, different input, " build'.platform;
H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build'.uuid
Uuidm.pp build.uuid]
a_href @@ Link.Compare_builds.make
~left:build'.uuid
~right:build.uuid ()]
[txtf "%a" pp_ptime build'.start]
])
different_input_same_output
@ -551,9 +547,9 @@ module Job_build = struct
H.li [
txtf "on %s, " build'.platform ;
H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build'.uuid
Uuidm.pp build.uuid]
a_href @@ Link.Compare_builds.make
~left:build'.uuid
~right:build.uuid ()]
[txtf "%a" pp_ptime build'.start]
])
same_input_different_output)
@ -572,9 +568,9 @@ module Job_build = struct
| Some b when not (Uuidm.equal build.uuid b.Builder_db.Build.uuid) ->
[ H.li [ H.txt ctx;
H.a ~a:[
Fmt.kstr H.a_href "/compare/%a/%a"
Uuidm.pp b.uuid
Uuidm.pp build.uuid ]
H.a_href @@ Link.Compare_builds.make
~left:b.uuid
~right:build.uuid () ]
[txtf "%a" pp_ptime b.start]]
]
| _ -> []
@ -587,7 +583,7 @@ module Job_build = struct
]
let make_build_info
~name
~job_name
~delta
~(build:Builder_db.Build.t)
~artifacts
@ -607,24 +603,30 @@ module Job_build = struct
H.ul [
H.li [
H.a ~a:H.[
Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp build.uuid
a_href @@ Link.Job_build_artifact.make
~job_name
~build:build.uuid
~artifact:`Console ()
] [H.txt "Console output"];
];
H.li [
H.a ~a:H.[
Fmt.kstr a_href "/job/%s/build/%a/script" name Uuidm.pp build.uuid
a_href @@ Link.Job_build_artifact.make
~job_name
~build:build.uuid
~artifact:`Script ()
] [H.txt "Build script"];
]
];
]
@ make_artifacts
~job_name:name
~job_name
~build_uuid:build.uuid
~artifacts
~main_binary
~solo5_manifest
@ make_reproductions
~name
~job_name
~build
~same_input_same_output
~different_input_same_output
@ -664,10 +666,11 @@ module Job_build = struct
"
]
let make_viz_section ~name ~artifacts ~uuid =
let make_viz_section ~job_name ~artifacts ~uuid =
let viz_deps =
let iframe =
let src = Fmt.str "/job/%s/build/%a/vizdependencies" name Uuidm.pp uuid in
let src = Link.Job_build_artifact.make ~job_name ~build:uuid
~artifact:`Viz_dependencies () in
H.iframe ~a:H.[
a_src src;
a_title "Opam dependencies";
@ -698,7 +701,8 @@ dependency.\
in
let viz_treemap = lazy (
let iframe =
let src = Fmt.str "/job/%s/build/%a/viztreemap" name Uuidm.pp uuid in
let src = Link.Job_build_artifact.make ~job_name ~build:uuid
~artifact:`Viz_treemap () in
H.iframe ~a:H.[
a_src src;
a_title "Binary dissection";
@ -726,7 +730,7 @@ and the rest of the unaccounted data.\
]
let make
~name
~job_name
~(build:Builder_db.Build.t)
~artifacts
~main_binary
@ -737,10 +741,10 @@ and the rest of the unaccounted data.\
~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 right_column = make_viz_section ~job_name ~artifacts ~uuid:build.uuid in
let left_column =
make_build_info
~name
~job_name
~delta
~build
~artifacts
@ -756,7 +760,7 @@ and the rest of the unaccounted data.\
H.a_style "width: 45em; min-width: 43em;" in
let style_col_right = H.a_style "width: 50%" in
let body = [
H.h1 [txtf "Job %s" name];
H.h1 [txtf "Job %s" job_name];
H.div~a:[ style_grid ] [
H.div~a:[ style_col_left ] left_column;
H.div~a:[ style_col_right ] right_column
@ -764,8 +768,8 @@ and the rest of the unaccounted data.\
]
in
layout
~nav:(`Build (name, build))
~title:(Fmt.str "Job %s %a" name pp_ptime build.start)
~nav:(`Build (job_name, build))
~title:(Fmt.str "Job %s %a" job_name pp_ptime build.start)
~manual_width:true
body
@ -840,28 +844,28 @@ let compare_builds
H.h1 [H.txt "Comparing builds"];
H.h2 [
H.txt "Builds ";
H.a ~a:H.[a_href
(Fmt.str "/job/%s/build/%a"
job_left
Uuidm.pp build_left.uuid)]
H.a ~a:H.[ a_href @@
Link.Job_build.make
~job_name:job_left
~build:build_left.uuid () ]
[ txtf "%s@%a %a"
job_left
pp_ptime build_left.start
pp_platform (Some build_left.platform)];
H.txt " and ";
H.a ~a:H.[a_href
(Fmt.str "/job/%s/build/%a"
job_right
Uuidm.pp build_right.uuid)]
H.a ~a:H.[ a_href @@
Link.Job_build.make
~job_name:job_right
~build:build_right.uuid () ]
[ txtf "%s@%a %a"
job_right
pp_ptime build_right.start
pp_platform (Some build_right.platform)];
];
H.h3 [ H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build_right.uuid
Uuidm.pp build_left.uuid ]
a_href @@ Link.Compare_builds.make
~left:build_right.uuid
~right:build_left.uuid () ]
[H.txt "Compare in reverse direction"]] ;
H.ul [
H.li [
@ -947,7 +951,7 @@ let failed_builds ~start ~count builds =
H.li [
check_icon build.Builder_db.Build.result;
txtf " %s %a " job_name pp_platform (Some build.platform);
H.a ~a:H.[Fmt.kstr a_href "/job/%s/build/%a" job_name Uuidm.pp build.uuid]
H.a ~a:H.[ a_href @@ Link.Job_build.make ~job_name ~build:build.uuid () ]
[txtf "%a" pp_ptime build.start];
txtf " %a" Builder.pp_execution_result build.result;
]
@ -958,8 +962,8 @@ let failed_builds ~start ~count builds =
H.ul (List.map build builds);
H.p [ txtf "View the next %d failed builds " count;
H.a ~a:H.[
Fmt.kstr a_href "/failed-builds/?count=%d&start=%d"
count (start + count) ]
a_href @@ Link.Failed_builds.make
~count ~start:(start + count) () ]
[ H.txt "here"];
H.txt ".";
]