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

Removing trailing slashes (#80)

Browse source 
This PR solves the issue of there being both "<url>/" and "<url>" paths, that in the builder-web context shouldn't mean different things.

The slashes are now removed using a `Dream` middleware, and the request is redirected using a permanent redirect (that doesn't change the method used): https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Location

Notable changes:
* Trailing slashes from the hardcoded link urls were removed, as unneccesary redirects are then avoided.
* All links in `Views` were rewritten to be absolute instead of relative.
* As `Dream` deprecated `path` - `Utils.Path` was created containing some helpers for manipulating paths. *Note that `String.split_on_char` has a different semantics.*
* A blacklist `routeprefix_blacklist_when_removing_trailing_slash` was added, containing `Dream` route-prefixes to ignore.
* Only `GET` and `HEAD` requests are redirected.
* `redirect_parent` helper was rewritten using new `Utils.Path` functions to avoid brittle string manipulation + fixed the edgecase of redirecting to `/`.
* Added `Uri` dependency to make URL manipulation safer.

Co-authored-by: rand00 <oth.rand@gmail.com>
Co-authored-by: Reynir Björnsson <reynir@reynir.dk>
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/80
Co-authored-by: rand <rand@r7p5.earth>
Co-committed-by: rand <rand@r7p5.earth>
This commit is contained in:
rand 2022-04-21 10:40:21 +00:00
parent e5a2b6fc0e
commit 0f493e9b47
6 changed files with 123 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
bin/builder_web_app.ml
View file

@ -112,6 +112,7 @@ let setup_app level influx port host datadir cachedir configdir =
@@ Dream.logger
@@ Dream.sql_pool ("sqlite3:" ^ dbpath)
@@ Http_status_metrics.handle
@@ Builder_web.Middleware.remove_trailing_url_slash
@@ Builder_web.add_routes ~datadir ~cachedir ~configdir
@@ Builder_web.not_found

2
builder-web.opam
View file

@ -15,7 +15,7 @@ build: [
]
depends: [
"ocaml" {>= "4.10.0"}
"ocaml" {>= "4.13.0"}
"dune" {>= "2.7.0"}
"builder" {>= "0.2.0"}
"dream" {= "1.0.0~alpha2"}

59
lib/builder_web.ml
View file

@ -379,7 +379,7 @@ let add_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)
(Fmt.str "/job/%s/build/%a" job_name Uuidm.pp build.Builder_db.Build.uuid)
|> Lwt_result.ok
in
@ -469,18 +469,16 @@ let add_routes ~datadir ~cachedir ~configdir =
in
let redirect_parent req =
let parent =
Dream.target req |>
String.split_on_char '/' |>
List.rev |> List.tl |> List.rev |>
String.concat "/"
let queries = Dream.all_queries req in
let parent_url =
let parent_path =
Dream.target req
|> Utils.Path.of_url
|> List.rev |> List.tl |> List.rev
in
Utils.Path.to_url ~path:parent_path ~queries
in
let parent = parent ^ "/" in
let url = match Dream.all_queries req with
| [] -> parent
| xs -> parent ^ "?" ^ (Dream.to_form_urlencoded xs)
in
Dream.redirect ~status:`Temporary_Redirect req url
Dream.redirect ~status:`Temporary_Redirect req parent_url
|> Lwt_result.ok
in
@ -489,21 +487,48 @@ let add_routes ~datadir ~cachedir ~configdir =
Dream.router [
Dream.get "/" (w builds);
Dream.get "/job" (w redirect_parent);
Dream.get "/job/:job/" (w job);
Dream.get "/job/:job" (w job);
Dream.get "/job/:job/build" (w redirect_parent);
Dream.get "/job/:job/failed/" (w job_with_failed);
Dream.get "/job/:job/failed" (w job_with_failed);
Dream.get "/job/:job/build/latest/**" (w redirect_latest);
Dream.get "/job/:job/build/:build/" (w job_build);
Dream.get "/job/:job/build/:build" (w job_build);
Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
Dream.get "/job/:job/build/:build/main-binary" (w redirect_main_binary);
Dream.get "/job/:job/build/:build/viztreemap" (w @@ job_build_viz `Treemap);
Dream.get "/job/:job/build/:build/vizdependencies" (w @@ job_build_viz `Dependencies);
Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script));
Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console));
Dream.get "/failed-builds/" (w failed_builds);
Dream.get "/failed-builds" (w failed_builds);
Dream.get "/job/:job/build/:build/all.tar" (w job_build_tar);
Dream.get "/hash" (w hash);
Dream.get "/compare/:build_left/:build_right/" (w compare_builds);
Dream.get "/compare/:build_left/:build_right" (w compare_builds);
Dream.post "/upload" (Authorization.authenticate (w upload));
Dream.post "/job/:job/platform/:platform/upload" (Authorization.authenticate (w upload_binary));
]
let routeprefix_blacklist_when_removing_trailing_slash = [
"/job/:job/build/:build/f"
]
module Middleware = struct
let remove_trailing_url_slash : Dream.middleware =
fun handler req ->
let path = Dream.target req |> Utils.Path.of_url in
let is_blacklisted =
routeprefix_blacklist_when_removing_trailing_slash
|> List.exists (Utils.Path.matches_dreamroute ~path)
in
if not (List.mem (Dream.method_ req) [`GET; `HEAD]) || is_blacklisted then
handler req
else match List.rev path with
| "" :: [] (* / *) -> handler req
| "" :: path (* /.../ *) ->
let path = List.rev path in
let queries = Dream.all_queries req in
let url = Utils.Path.to_url ~path ~queries in
(*> Note: See https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Location*)
Dream.redirect ~status:`Permanent_Redirect req url
| _ (* /... *) -> handler req
end

1
lib/dune
View file

@ -6,4 +6,5 @@
opamdiff ptime.clock.os omd tar
owee
solo5-elftool
uri
))

36
lib/utils.ml
View file

@ -124,3 +124,39 @@ module Omd = struct
|> Omd.to_html
end
module Path = struct
let to_url ~path ~queries =
let path = match path with
| "" :: [] -> "/"
| path -> "/" ^ String.concat "/" path
in
let query = queries |> List.map (fun (k, v) -> k, [v]) in
Uri.make ~path ~query () |> Uri.to_string
(* Like Dream.path in 1.0.0~alpha2 but on Dream.target *)
let of_url uri_str =
let path_str = uri_str |> Uri.of_string |> Uri.path in
match String.split_on_char '/' path_str with
| "" :: (_ :: _ as tail) -> tail
| path -> path
let matches_dreamroute ~path dreamroute =
let is_match path_elem dpath_elem =
(dpath_elem |> String.starts_with ~prefix:":")
|| path_elem = dpath_elem
in
let rec aux path dreampath =
match path, dreampath with
| [] , _ :: _ -> false (*length path < length dreampath*)
| _ , [] -> true (*length path >= length dreampath *)
| _ :: _ , "" :: [] -> true (*dreampath ends in '/'*)
| p_elem :: path, dp_elem :: dreampath ->
is_match p_elem dp_elem
&& aux path dreampath
in
let dreampath = dreamroute |> of_url in
aux path dreampath
end

66
lib/views.ml
View file

@ -95,7 +95,7 @@ let make_breadcrumbs nav =
| `Job (job_name, platform) ->
to_nav [
H.txt "Home", "/";
txtf "Job %s" job_name, Fmt.str "/job/%s/" job_name ;
txtf "Job %s" job_name, Fmt.str "/job/%s" job_name ;
(
txtf "%a" pp_platform platform,
Fmt.str "/job/%s/%a" job_name pp_platform_query platform
@ -104,7 +104,7 @@ let make_breadcrumbs nav =
| `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, Fmt.str "/job/%s" job_name;
(
txtf "%a" pp_platform (Some build.Builder_db.Build.platform),
Fmt.str "/job/%s/%a"
@ -113,7 +113,7 @@ let make_breadcrumbs nav =
);
(
txtf "Build %a" pp_ptime build.Builder_db.Build.start,
Fmt.str "/job/%s/build/%a/"
Fmt.str "/job/%s/build/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid
);
@ -125,7 +125,7 @@ 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/"
Fmt.str "/compare/%a/%a"
Uuidm.pp build_left.uuid
Uuidm.pp build_right.uuid
);
@ -231,7 +231,7 @@ let page_not_found ~path ~referer =
| None -> []
| Some prev_url -> [
H.p [
H.txt "Go back to ";
H.txt "Go back to ";
H.a ~a:H.[ a_href prev_url ] [ H.txt prev_url ];
];
]
@ -297,13 +297,13 @@ 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"
Fmt.kstr H.a_href "/job/%s/%a"
job_name
pp_platform_query (Some platform)]
[H.txt platform];
H.txt " ";
H.a ~a:[
Fmt.kstr H.a_href "job/%s/build/%a/"
Fmt.kstr H.a_href "/job/%s/build/%a/"
job_name
Uuidm.pp latest_build.Builder_db.Build.uuid]
[txtf "%a" pp_ptime latest_build.Builder_db.Build.start];
@ -326,7 +326,7 @@ have questions or suggestions.
jobs |> List.map (fun (job_name, synopsis, platform_builds) ->
H.li (
[
H.a ~a:H.[a_href ("job/" ^ job_name ^ "/")]
H.a ~a:H.[a_href ("/job/" ^ job_name ^ "/")]
[H.txt job_name];
H.br ();
H.txt (Option.value ~default:"" synopsis);
@ -348,7 +348,7 @@ have questions or suggestions.
let make_failed_builds =
[ H.p [
H.txt "View the latest failed builds ";
H.a ~a:H.[a_href "/failed-builds/"]
H.a ~a:H.[a_href "/failed-builds"]
[H.txt "here"];
H.txt "."
]]
@ -382,7 +382,7 @@ 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/"
Fmt.kstr a_href "/job/%s/build/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid ]
[
@ -411,15 +411,19 @@ module Job = struct
H.p [
H.txt "Excluding failed builds " ;
H.a ~a:H.[
a_href @@ Fmt.str "../%a" pp_platform_query platform
a_href @@ Fmt.str "/job/%s%a"
job_name
pp_platform_query platform
]
[H.txt "here"] ;
H.txt "." ]
else
H.p [
H.txt "Including failed builds " ;
H.txt "Including failed builds " ;
H.a ~a:H.[
a_href @@ Fmt.str "failed/%a" pp_platform_query platform
a_href @@ Fmt.str "/job/%s/failed%a"
job_name
pp_platform_query platform
]
[H.txt "here"] ;
H.txt "." ]
@ -445,7 +449,12 @@ module Job_build = struct
in
List.exists check artifacts
let make_artifacts ~artifacts ~main_binary ~solo5_manifest =
let make_artifacts
~job_name
~build_uuid
~artifacts
~main_binary
~solo5_manifest =
let solo5_devices solo5_manifest =
let pp_devices =
let pp_device_name ppf = function
@ -471,7 +480,11 @@ module Job_build = struct
let (`Hex sha256_hex) = Hex.of_cstruct file.sha256 in
[
H.dt [
H.a ~a:H.[Fmt.kstr a_href "f/%a" Fpath.pp file.filepath]
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.code [txtf "%a" Fpath.pp file.filepath]] ];
H.dd ([
H.code [H.txt "SHA256:"; H.txt sha256_hex];
@ -498,7 +511,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.[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp build.uuid]
[txtf "%a" pp_ptime build.start]
])
same_input_same_output
@ -508,7 +521,7 @@ module Job_build = struct
H.li [
txtf "on %s, different input, " build'.platform;
H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a/"
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build'.uuid
Uuidm.pp build.uuid]
[txtf "%a" pp_ptime build'.start]
@ -538,7 +551,7 @@ module Job_build = struct
H.li [
txtf "on %s, " build'.platform ;
H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a/"
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build'.uuid
Uuidm.pp build.uuid]
[txtf "%a" pp_ptime build'.start]
@ -559,7 +572,7 @@ 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/"
Fmt.kstr H.a_href "/compare/%a/%a"
Uuidm.pp b.uuid
Uuidm.pp build.uuid ]
[txtf "%a" pp_ptime b.start]]
@ -604,7 +617,12 @@ module Job_build = struct
]
];
]
@ make_artifacts ~artifacts ~main_binary ~solo5_manifest
@ make_artifacts
~job_name:name
~build_uuid:build.uuid
~artifacts
~main_binary
~solo5_manifest
@ make_reproductions
~name
~build
@ -823,7 +841,7 @@ let compare_builds
H.h2 [
H.txt "Builds ";
H.a ~a:H.[a_href
(Fmt.str "/job/%s/build/%a/"
(Fmt.str "/job/%s/build/%a"
job_left
Uuidm.pp build_left.uuid)]
[ txtf "%s@%a %a"
@ -832,7 +850,7 @@ let compare_builds
pp_platform (Some build_left.platform)];
H.txt " and ";
H.a ~a:H.[a_href
(Fmt.str "/job/%s/build/%a/"
(Fmt.str "/job/%s/build/%a"
job_right
Uuidm.pp build_right.uuid)]
[ txtf "%s@%a %a"
@ -841,7 +859,7 @@ let compare_builds
pp_platform (Some build_right.platform)];
];
H.h3 [ H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a/"
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build_right.uuid
Uuidm.pp build_left.uuid ]
[H.txt "Compare in reverse direction"]] ;
@ -929,7 +947,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.[Fmt.kstr a_href "/job/%s/build/%a" job_name Uuidm.pp build.uuid]
[txtf "%a" pp_ptime build.start];
txtf " %a" Builder.pp_execution_result build.result;
]